script_ir_translator.ml 262 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
open Micheline
open Script
open Script_typed_ir
open Script_tc_errors
open Script_ir_annot
module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking
module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse
type ex_comparable_ty =
| Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty
type ex_ty = Ex_ty : 'a ty -> ex_ty
type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty
type tc_context =
| Lambda : tc_context
| Dip : 'a stack_ty * tc_context -> tc_context
| Toplevel : {
storage_type : 'sto ty;
param_type : 'param ty;
root_name : string option;
legacy_create_contract_literal : bool;
}
-> tc_context
type unparsing_mode = Optimized | Readable
type type_logger =
int ->
(Script.expr * Script.annot) list ->
(Script.expr * Script.annot) list ->
unit
let add_dip ty annot prev =
match prev with
| Lambda | Toplevel _ ->
Dip (Item_t (ty, Empty_t, annot), prev)
| Dip (stack, _) ->
Dip (Item_t (ty, stack, annot), prev)
(* ---- Type size accounting ------------------------------------------------*)
let rec comparable_type_size : type t a. (t, a) comparable_struct -> int =
fun ty ->
(* No wildcard to force the update when comparable_ty chages. *)
match ty with
| Int_key _ ->
1
| Nat_key _ ->
1
| String_key _ ->
1
| Bytes_key _ ->
1
| Mutez_key _ ->
1
| Bool_key _ ->
1
| Key_hash_key _ ->
1
| Timestamp_key _ ->
1
| Address_key _ ->
1
| Pair_key (_, (t, _), _) ->
1 + comparable_type_size t
let rec type_size : type t. t ty -> int =
fun ty ->
match ty with
| Unit_t _ ->
1
| Int_t _ ->
1
| Nat_t _ ->
1
| Signature_t _ ->
1
| Bytes_t _ ->
1
| String_t _ ->
1
| Mutez_t _ ->
1
| Key_hash_t _ ->
1
| Key_t _ ->
1
| Timestamp_t _ ->
1
| Address_t _ ->
1
| Bool_t _ ->
1
| Operation_t _ ->
1
| Pair_t ((l, _, _), (r, _, _), _, _) ->
1 + type_size l + type_size r
| Union_t ((l, _), (r, _), _, _) ->
1 + type_size l + type_size r
| Lambda_t (arg, ret, _) ->
1 + type_size arg + type_size ret
| Option_t (t, _, _) ->
1 + type_size t
| List_t (t, _, _) ->
1 + type_size t
| Set_t (k, _) ->
1 + comparable_type_size k
| Map_t (k, v, _, _) ->
1 + comparable_type_size k + type_size v
| Big_map_t (k, v, _) ->
1 + comparable_type_size k + type_size v
| Contract_t (arg, _) ->
1 + type_size arg
| Chain_id_t _ ->
1
let rec type_size_of_stack_head : type st. st stack_ty -> up_to:int -> int =
fun stack ~up_to ->
match stack with
| Empty_t ->
0
| Item_t (head, tail, _annot) ->
if Compare.Int.(up_to > 0) then
Compare.Int.max
(type_size head)
(type_size_of_stack_head tail ~up_to:(up_to - 1))
else 0
(* This is the depth of the stack to inspect for sizes overflow. We
only need to check the produced types that can be larger than the
arguments. That's why Swap is 0 for instance as no type grows.
Constant sized types are not checked: it is assumed they are lower
than the bound (otherwise every program would be rejected). *)
let number_of_generated_growing_types : type b a. (b, a) instr -> int =
function
| Drop ->
0
| Dup ->
0
| Swap ->
0
| Const _ ->
1
| Cons_pair ->
1
| Car ->
0
| Cdr ->
0
| Cons_some ->
1
| Cons_none _ ->
1
| If_none _ ->
0
| Left ->
0
| Right ->
0
| If_left _ ->
0
| Cons_list ->
1
| Nil ->
1
| If_cons _ ->
0
| List_map _ ->
1
| List_size ->
0
| List_iter _ ->
1
| Empty_set _ ->
1
| Set_iter _ ->
0
| Set_mem ->
0
| Set_update ->
0
| Set_size ->
0
| Empty_map _ ->
1
| Map_map _ ->
1
| Map_iter _ ->
1
| Map_mem ->
0
| Map_get ->
0
| Map_update ->
0
| Map_size ->
0
| Empty_big_map _ ->
1
| Big_map_get ->
0
| Big_map_update ->
0
| Big_map_mem ->
0
| Concat_string ->
0
| Concat_string_pair ->
0
| Slice_string ->
0
| String_size ->
0
| Concat_bytes ->
0
| Concat_bytes_pair ->
0
| Slice_bytes ->
0
| Bytes_size ->
0
| Add_seconds_to_timestamp ->
0
| Add_timestamp_to_seconds ->
0
| Sub_timestamp_seconds ->
0
| Diff_timestamps ->
0
| Add_tez ->
0
| Sub_tez ->
0
| Mul_teznat ->
0
| Mul_nattez ->
0
| Ediv_teznat ->
0
| Ediv_tez ->
0
| Or ->
0
| And ->
0
| Xor ->
0
| Not ->
0
| Is_nat ->
0
| Neg_nat ->
0
| Neg_int ->
0
| Abs_int ->
0
| Int_nat ->
0
| Add_intint ->
0
| Add_intnat ->
0
| Add_natint ->
0
| Add_natnat ->
0
| Sub_int ->
0
| Mul_intint ->
0
| Mul_intnat ->
0
| Mul_natint ->
0
| Mul_natnat ->
0
| Ediv_intint ->
0
| Ediv_intnat ->
0
| Ediv_natint ->
0
| Ediv_natnat ->
0
| Lsl_nat ->
0
| Lsr_nat ->
0
| Or_nat ->
0
| And_nat ->
0
| And_int_nat ->
0
| Xor_nat ->
0
| Not_nat ->
0
| Not_int ->
0
| Seq _ ->
0
| If _ ->
0
| Loop _ ->
0
| Loop_left _ ->
0
| Dip _ ->
0
| Exec ->
0
| Apply _ ->
0
| Lambda _ ->
1
| Failwith _ ->
1
| Nop ->
0
| Compare _ ->
1
| Eq ->
0
| Neq ->
0
| Lt ->
0
| Gt ->
0
| Le ->
0
| Ge ->
0
| Address ->
0
| Contract _ ->
1
| Transfer_tokens ->
1
| Create_account ->
0
| Implicit_account ->
0
| Create_contract _ ->
1
| Create_contract_2 _ ->
1
| Now ->
0
| Balance ->
0
| Check_signature ->
0
| Hash_key ->
0
| Blake2b ->
0
| Sha256 ->
0
| Sha512 ->
0
| Steps_to_quota ->
0
| Source ->
0
| Sender ->
0
| Self _ ->
1
| Amount ->
0
| Set_delegate ->
0
| Pack _ ->
0
| Unpack _ ->
1
| Dig _ ->
0
| Dug _ ->
0
| Dipn _ ->
0
| Dropn _ ->
0
| ChainId ->
0
(* ---- Error helpers -------------------------------------------------------*)
let location = function
| Prim (loc, _, _, _)
| Int (loc, _)
| String (loc, _)
| Bytes (loc, _)
| Seq (loc, _) ->
loc
let kind = function
| Int _ ->
Int_kind
| String _ ->
String_kind
| Bytes _ ->
Bytes_kind
| Prim _ ->
Prim_kind
| Seq _ ->
Seq_kind
let namespace = function
| K_parameter | K_storage | K_code ->
Keyword_namespace
| D_False
| D_Elt
| D_Left
| D_None
| D_Pair
| D_Right
| D_Some
| D_True
| D_Unit ->
Constant_namespace
| I_PACK
| I_UNPACK
| I_BLAKE2B
| I_SHA256
| I_SHA512
| I_ABS
| I_ADD
| I_AMOUNT
| I_AND
| I_BALANCE
| I_CAR
| I_CDR
| I_CHAIN_ID
| I_CHECK_SIGNATURE
| I_COMPARE
| I_CONCAT
| I_CONS
| I_CREATE_ACCOUNT
| I_CREATE_CONTRACT
| I_IMPLICIT_ACCOUNT
| I_DIP
| I_DROP
| I_DUP
| I_EDIV
| I_EMPTY_BIG_MAP
| I_EMPTY_MAP
| I_EMPTY_SET
| I_EQ
| I_EXEC
| I_APPLY
| I_FAILWITH
| I_GE
| I_GET
| I_GT
| I_HASH_KEY
| I_IF
| I_IF_CONS
| I_IF_LEFT
| I_IF_NONE
| I_INT
| I_LAMBDA
| I_LE
| I_LEFT
| I_LOOP
| I_LSL
| I_LSR
| I_LT
| I_MAP
| I_MEM
| I_MUL
| I_NEG
| I_NEQ
| I_NIL
| I_NONE
| I_NOT
| I_NOW
| I_OR
| I_PAIR
| I_PUSH
| I_RIGHT
| I_SIZE
| I_SOME
| I_SOURCE
| I_SENDER
| I_SELF
| I_SLICE
| I_STEPS_TO_QUOTA
| I_SUB
| I_SWAP
| I_TRANSFER_TOKENS
| I_SET_DELEGATE
| I_UNIT
| I_UPDATE
| I_XOR
| I_ITER
| I_LOOP_LEFT
| I_ADDRESS
| I_CONTRACT
| I_ISNAT
| I_CAST
| I_RENAME
| I_DIG
| I_DUG ->
Instr_namespace
| T_bool
| T_contract
| T_int
| T_key
| T_key_hash
| T_lambda
| T_list
| T_map
| T_big_map
| T_nat
| T_option
| T_or
| T_pair
| T_set
| T_signature
| T_string
| T_bytes
| T_mutez
| T_timestamp
| T_unit
| T_operation
| T_address
| T_chain_id ->
Type_namespace
let unexpected expr exp_kinds exp_ns exp_prims =
match expr with
| Int (loc, _) ->
Invalid_kind (loc, Prim_kind :: exp_kinds, Int_kind)
| String (loc, _) ->
Invalid_kind (loc, Prim_kind :: exp_kinds, String_kind)
| Bytes (loc, _) ->
Invalid_kind (loc, Prim_kind :: exp_kinds, Bytes_kind)
| Seq (loc, _) ->
Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind)
| Prim (loc, name, _, _) -> (
match (namespace name, exp_ns) with
| (Type_namespace, Type_namespace)
| (Instr_namespace, Instr_namespace)
| (Constant_namespace, Constant_namespace) ->
Invalid_primitive (loc, exp_prims, name)
| (ns, _) ->
Invalid_namespace (loc, name, exp_ns, ns) )
let check_kind kinds expr =
let kind = kind expr in
if List.mem kind kinds then return_unit
else
let loc = location expr in
fail (Invalid_kind (loc, kinds, kind))
(* ---- Sets and Maps -------------------------------------------------------*)
let wrap_compare compare a b =
let res = compare a b in
if Compare.Int.(res = 0) then 0 else if Compare.Int.(res > 0) then 1 else -1
let rec compare_comparable :
type a s. (a, s) comparable_struct -> a -> a -> int =
fun kind ->
match kind with
| String_key _ ->
wrap_compare Compare.String.compare
| Bool_key _ ->
wrap_compare Compare.Bool.compare
| Mutez_key _ ->
wrap_compare Tez.compare
| Key_hash_key _ ->
wrap_compare Signature.Public_key_hash.compare
| Int_key _ ->
wrap_compare Script_int.compare
| Nat_key _ ->
wrap_compare Script_int.compare
| Timestamp_key _ ->
wrap_compare Script_timestamp.compare
| Address_key _ ->
wrap_compare
@@ fun (x, ex) (y, ey) ->
let lres = Contract.compare x y in
if Compare.Int.(lres = 0) then Compare.String.compare ex ey else lres
| Bytes_key _ ->
wrap_compare MBytes.compare
| Pair_key ((tl, _), (tr, _), _) ->
fun (lx, rx) (ly, ry) ->
let lres = compare_comparable tl lx ly in
if Compare.Int.(lres = 0) then compare_comparable tr rx ry else lres
let empty_set : type a. a comparable_ty -> a set =
fun ty ->
let module OPS = Set.Make (struct
type t = a
let compare = compare_comparable ty
end) in
( module struct
type elt = a
let elt_ty = ty
module OPS = OPS
let boxed = OPS.empty
let size = 0
end )
let set_update : type a. a -> bool -> a set -> a set =
fun v b (module Box) ->
( module struct
type elt = a
let elt_ty = Box.elt_ty
module OPS = Box.OPS
let boxed =
if b then Box.OPS.add v Box.boxed else Box.OPS.remove v Box.boxed
let size =
let mem = Box.OPS.mem v Box.boxed in
if mem then if b then Box.size else Box.size - 1
else if b then Box.size + 1
else Box.size
end )
let set_mem : type elt. elt -> elt set -> bool =
fun v (module Box) -> Box.OPS.mem v Box.boxed
let set_fold : type elt acc. (elt -> acc -> acc) -> elt set -> acc -> acc =
fun f (module Box) -> Box.OPS.fold f Box.boxed
let set_size : type elt. elt set -> Script_int.n Script_int.num =
fun (module Box) -> Script_int.(abs (of_int Box.size))
let map_key_ty : type a b. (a, b) map -> a comparable_ty =
fun (module Box) -> Box.key_ty
let empty_map : type a b. a comparable_ty -> (a, b) map =
fun ty ->
let module OPS = Map.Make (struct
type t = a
let compare = compare_comparable ty
end) in
( module struct
type key = a
type value = b
let key_ty = ty
module OPS = OPS
let boxed = (OPS.empty, 0)
end )
let map_get : type key value. key -> (key, value) map -> value option =
fun k (module Box) -> Box.OPS.find_opt k (fst Box.boxed)
let map_update : type a b. a -> b option -> (a, b) map -> (a, b) map =
fun k v (module Box) ->
( module struct
type key = a
type value = b
let key_ty = Box.key_ty
module OPS = Box.OPS
let boxed =
let (map, size) = Box.boxed in
let contains = Box.OPS.mem k map in
match v with
| Some v ->
(Box.OPS.add k v map, size + if contains then 0 else 1)
| None ->
(Box.OPS.remove k map, size - if contains then 1 else 0)
end )
let map_set : type a b. a -> b -> (a, b) map -> (a, b) map =
fun k v (module Box) ->
( module struct
type key = a
type value = b
let key_ty = Box.key_ty
module OPS = Box.OPS
let boxed =
let (map, size) = Box.boxed in
(Box.OPS.add k v map, if Box.OPS.mem k map then size else size + 1)
end )
let map_mem : type key value. key -> (key, value) map -> bool =
fun k (module Box) -> Box.OPS.mem k (fst Box.boxed)
let map_fold :
type key value acc.
(key -> value -> acc -> acc) -> (key, value) map -> acc -> acc =
fun f (module Box) -> Box.OPS.fold f (fst Box.boxed)
let map_size : type key value. (key, value) map -> Script_int.n Script_int.num
=
fun (module Box) -> Script_int.(abs (of_int (snd Box.boxed)))
(* ---- Unparsing (Typed IR -> Untyped expressions) of types -----------------*)
let rec ty_of_comparable_ty : type a s. (a, s) comparable_struct -> a ty =
function
| Int_key tname ->
Int_t tname
| Nat_key tname ->
Nat_t tname
| String_key tname ->
String_t tname
| Bytes_key tname ->
Bytes_t tname
| Mutez_key tname ->
Mutez_t tname
| Bool_key tname ->
Bool_t tname
| Key_hash_key tname ->
Key_hash_t tname
| Timestamp_key tname ->
Timestamp_t tname
| Address_key tname ->
Address_t tname
| Pair_key ((l, al), (r, ar), tname) ->
Pair_t
( (ty_of_comparable_ty l, al, None),
(ty_of_comparable_ty r, ar, None),
tname,
false )
let rec comparable_ty_of_ty : type a. a ty -> a comparable_ty option = function
| Int_t tname ->
Some (Int_key tname)
| Nat_t tname ->
Some (Nat_key tname)
| String_t tname ->
Some (String_key tname)
| Bytes_t tname ->
Some (Bytes_key tname)
| Mutez_t tname ->
Some (Mutez_key tname)
| Bool_t tname ->
Some (Bool_key tname)
| Key_hash_t tname ->
Some (Key_hash_key tname)
| Timestamp_t tname ->
Some (Timestamp_key tname)
| Address_t tname ->
Some (Address_key tname)
| Pair_t ((l, al, _), (r, ar, _), pname, _) -> (
match comparable_ty_of_ty r with
| None ->
None
| Some rty -> (
match comparable_ty_of_ty l with
| None ->
None
| Some (Pair_key _) ->
None (* not a comb *)
| Some (Int_key tname) ->
Some (Pair_key ((Int_key tname, al), (rty, ar), pname))
| Some (Nat_key tname) ->
Some (Pair_key ((Nat_key tname, al), (rty, ar), pname))
| Some (String_key tname) ->
Some (Pair_key ((String_key tname, al), (rty, ar), pname))
| Some (Bytes_key tname) ->
Some (Pair_key ((Bytes_key tname, al), (rty, ar), pname))
| Some (Mutez_key tname) ->
Some (Pair_key ((Mutez_key tname, al), (rty, ar), pname))
| Some (Bool_key tname) ->
Some (Pair_key ((Bool_key tname, al), (rty, ar), pname))
| Some (Key_hash_key tname) ->
Some (Pair_key ((Key_hash_key tname, al), (rty, ar), pname))
| Some (Timestamp_key tname) ->
Some (Pair_key ((Timestamp_key tname, al), (rty, ar), pname))
| Some (Address_key tname) ->
Some (Pair_key ((Address_key tname, al), (rty, ar), pname)) ) )
| _ ->
None
let add_field_annot a var = function
| Prim (loc, prim, args, annots) ->
Prim
( loc,
prim,
args,
annots @ unparse_field_annot a @ unparse_var_annot var )
| expr ->
expr
let rec unparse_comparable_ty :
type a s. (a, s) comparable_struct -> Script.node = function
| Int_key tname ->
Prim (-1, T_int, [], unparse_type_annot tname)
| Nat_key tname ->
Prim (-1, T_nat, [], unparse_type_annot tname)
| String_key tname ->
Prim (-1, T_string, [], unparse_type_annot tname)
| Bytes_key tname ->
Prim (-1, T_bytes, [], unparse_type_annot tname)
| Mutez_key tname ->
Prim (-1, T_mutez, [], unparse_type_annot tname)
| Bool_key tname ->
Prim (-1, T_bool, [], unparse_type_annot tname)
| Key_hash_key tname ->
Prim (-1, T_key_hash, [], unparse_type_annot tname)
| Timestamp_key tname ->
Prim (-1, T_timestamp, [], unparse_type_annot tname)
| Address_key tname ->
Prim (-1, T_address, [], unparse_type_annot tname)
| Pair_key ((l, al), (r, ar), pname) ->
let tl = add_field_annot al None (unparse_comparable_ty l) in
let tr = add_field_annot ar None (unparse_comparable_ty r) in
Prim (-1, T_pair, [tl; tr], unparse_type_annot pname)
let rec unparse_ty_no_lwt :
type a. context -> a ty -> (Script.node * context) tzresult =
fun ctxt ty ->
Gas.consume ctxt Unparse_costs.cycle
>>? fun ctxt ->
let return ctxt (name, args, annot) =
let result = Prim (-1, name, args, annot) in
Gas.consume ctxt (Unparse_costs.prim_cost (List.length args) annot)
>>? fun ctxt -> ok (result, ctxt)
in
match ty with
| Unit_t tname ->
return ctxt (T_unit, [], unparse_type_annot tname)
| Int_t tname ->
return ctxt (T_int, [], unparse_type_annot tname)
| Nat_t tname ->
return ctxt (T_nat, [], unparse_type_annot tname)
| String_t tname ->
return ctxt (T_string, [], unparse_type_annot tname)
| Bytes_t tname ->
return ctxt (T_bytes, [], unparse_type_annot tname)
| Mutez_t tname ->
return ctxt (T_mutez, [], unparse_type_annot tname)
| Bool_t tname ->
return ctxt (T_bool, [], unparse_type_annot tname)
| Key_hash_t tname ->
return ctxt (T_key_hash, [], unparse_type_annot tname)
| Key_t tname ->
return ctxt (T_key, [], unparse_type_annot tname)
| Timestamp_t tname ->
return ctxt (T_timestamp, [], unparse_type_annot tname)
| Address_t tname ->
return ctxt (T_address, [], unparse_type_annot tname)
| Signature_t tname ->
return ctxt (T_signature, [], unparse_type_annot tname)
| Operation_t tname ->
return ctxt (T_operation, [], unparse_type_annot tname)
| Chain_id_t tname ->
return ctxt (T_chain_id, [], unparse_type_annot tname)
| Contract_t (ut, tname) ->
unparse_ty_no_lwt ctxt ut
>>? fun (t, ctxt) ->
return ctxt (T_contract, [t], unparse_type_annot tname)
| Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname, _) ->
let annot = unparse_type_annot tname in
unparse_ty_no_lwt ctxt utl
>>? fun (utl, ctxt) ->
let tl = add_field_annot l_field l_var utl in
unparse_ty_no_lwt ctxt utr
>>? fun (utr, ctxt) ->
let tr = add_field_annot r_field r_var utr in
return ctxt (T_pair, [tl; tr], annot)
| Union_t ((utl, l_field), (utr, r_field), tname, _) ->
let annot = unparse_type_annot tname in
unparse_ty_no_lwt ctxt utl
>>? fun (utl, ctxt) ->
let tl = add_field_annot l_field None utl in
unparse_ty_no_lwt ctxt utr
>>? fun (utr, ctxt) ->
let tr = add_field_annot r_field None utr in
return ctxt (T_or, [tl; tr], annot)
| Lambda_t (uta, utr, tname) ->
unparse_ty_no_lwt ctxt uta
>>? fun (ta, ctxt) ->
unparse_ty_no_lwt ctxt utr
>>? fun (tr, ctxt) ->
return ctxt (T_lambda, [ta; tr], unparse_type_annot tname)
| Option_t (ut, tname, _) ->
let annot = unparse_type_annot tname in
unparse_ty_no_lwt ctxt ut
>>? fun (ut, ctxt) -> return ctxt (T_option, [ut], annot)
| List_t (ut, tname, _) ->
unparse_ty_no_lwt ctxt ut
>>? fun (t, ctxt) -> return ctxt (T_list, [t], unparse_type_annot tname)
| Set_t (ut, tname) ->
let t = unparse_comparable_ty ut in
return ctxt (T_set, [t], unparse_type_annot tname)
| Map_t (uta, utr, tname, _) ->
let ta = unparse_comparable_ty uta in
unparse_ty_no_lwt ctxt utr
>>? fun (tr, ctxt) ->
return ctxt (T_map, [ta; tr], unparse_type_annot tname)
| Big_map_t (uta, utr, tname) ->
let ta = unparse_comparable_ty uta in
unparse_ty_no_lwt ctxt utr
>>? fun (tr, ctxt) ->
return ctxt (T_big_map, [ta; tr], unparse_type_annot tname)
let unparse_ty ctxt ty = Lwt.return (unparse_ty_no_lwt ctxt ty)
let rec strip_var_annots = function
| (Int _ | String _ | Bytes _) as atom ->
atom
| Seq (loc, args) ->
Seq (loc, List.map strip_var_annots args)
| Prim (loc, name, args, annots) ->
let not_var_annot s = Compare.Char.(s.[0] <> '@') in
let annots = List.filter not_var_annot annots in
Prim (loc, name, List.map strip_var_annots args, annots)
let serialize_ty_for_error ctxt ty =
unparse_ty_no_lwt ctxt ty
|> record_trace Cannot_serialize_error
>|? fun (ty, ctxt) -> (strip_locations (strip_var_annots ty), ctxt)
let rec unparse_stack :
type a.
context ->
a stack_ty ->
((Script.expr * Script.annot) list * context) tzresult Lwt.t =
fun ctxt -> function
| Empty_t ->
return ([], ctxt)
| Item_t (ty, rest, annot) ->
unparse_ty ctxt ty
>>=? fun (uty, ctxt) ->
unparse_stack ctxt rest
>>=? fun (urest, ctxt) ->
return ((strip_locations uty, unparse_var_annot annot) :: urest, ctxt)
let serialize_stack_for_error ctxt stack_ty =
trace Cannot_serialize_error (unparse_stack ctxt stack_ty)
let name_of_ty : type a. a ty -> type_annot option = function
| Unit_t tname ->
tname
| Int_t tname ->
tname
| Nat_t tname ->
tname
| String_t tname ->
tname
| Bytes_t tname ->
tname
| Mutez_t tname ->
tname
| Bool_t tname ->
tname
| Key_hash_t tname ->
tname
| Key_t tname ->
tname
| Timestamp_t tname ->
tname
| Address_t tname ->
tname
| Signature_t tname ->
tname
| Operation_t tname ->
tname
| Chain_id_t tname ->
tname
| Contract_t (_, tname) ->
tname
| Pair_t (_, _, tname, _) ->
tname
| Union_t (_, _, tname, _) ->
tname
| Lambda_t (_, _, tname) ->
tname
| Option_t (_, tname, _) ->
tname
| List_t (_, tname, _) ->
tname
| Set_t (_, tname) ->
tname
| Map_t (_, _, tname, _) ->
tname
| Big_map_t (_, _, tname) ->
tname
(* ---- Equality witnesses --------------------------------------------------*)
type ('ta, 'tb) eq = Eq : ('same, 'same) eq
let comparable_ty_eq :
type ta tb.
context ->
ta comparable_ty ->
tb comparable_ty ->
(ta comparable_ty, tb comparable_ty) eq tzresult =
fun ctxt ta tb ->
match (ta, tb) with
| (Int_key _, Int_key _) ->
Ok Eq
| (Nat_key _, Nat_key _) ->
Ok Eq
| (String_key _, String_key _) ->
Ok Eq
| (Bytes_key _, Bytes_key _) ->
Ok Eq
| (Mutez_key _, Mutez_key _) ->
Ok Eq
| (Bool_key _, Bool_key _) ->
Ok Eq
| (Key_hash_key _, Key_hash_key _) ->
Ok Eq
| (Timestamp_key _, Timestamp_key _) ->
Ok Eq
| (Address_key _, Address_key _) ->
Ok Eq
| (_, _) ->
serialize_ty_for_error ctxt (ty_of_comparable_ty ta)
>>? fun (ta, ctxt) ->
serialize_ty_for_error ctxt (ty_of_comparable_ty tb)
>>? fun (tb, _ctxt) -> error (Inconsistent_types (ta, tb))
let record_inconsistent ctxt ta tb =
record_trace_eval (fun () ->
serialize_ty_for_error ctxt ta
>>? fun (ta, ctxt) ->
serialize_ty_for_error ctxt tb
>|? fun (tb, _ctxt) -> Inconsistent_types (ta, tb))
let record_inconsistent_type_annotations ctxt loc ta tb =
record_trace_eval (fun () ->
serialize_ty_for_error ctxt ta
>>? fun (ta, ctxt) ->
serialize_ty_for_error ctxt tb
>|? fun (tb, _ctxt) -> Inconsistent_type_annotations (loc, ta, tb))
let rec ty_eq :
type ta tb.
context -> ta ty -> tb ty -> ((ta ty, tb ty) eq * context) tzresult =
fun ctxt ta tb ->
let ok (eq : (ta ty, tb ty) eq) ctxt nb_args :
((ta ty, tb ty) eq * context) tzresult =
Gas.consume ctxt (Typecheck_costs.type_ (2 * nb_args))
>>? fun ctxt -> Ok (eq, ctxt)
in
Gas.consume ctxt Typecheck_costs.cycle
>>? fun ctxt ->
match (ta, tb) with
| (Unit_t _, Unit_t _) ->
ok Eq ctxt 0
| (Int_t _, Int_t _) ->
ok Eq ctxt 0
| (Nat_t _, Nat_t _) ->
ok Eq ctxt 0
| (Key_t _, Key_t _) ->
ok Eq ctxt 0
| (Key_hash_t _, Key_hash_t _) ->
ok Eq ctxt 0
| (String_t _, String_t _) ->
ok Eq ctxt 0
| (Bytes_t _, Bytes_t _) ->
ok Eq ctxt 0
| (Signature_t _, Signature_t _) ->
ok Eq ctxt 0
| (Mutez_t _, Mutez_t _) ->
ok Eq ctxt 0
| (Timestamp_t _, Timestamp_t _) ->
ok Eq ctxt 0
| (Chain_id_t _, Chain_id_t _) ->
ok Eq ctxt 0
| (Address_t _, Address_t _) ->
ok Eq ctxt 0
| (Bool_t _, Bool_t _) ->
ok Eq ctxt 0
| (Operation_t _, Operation_t _) ->
ok Eq ctxt 0
| (Map_t (tal, tar, _, _), Map_t (tbl, tbr, _, _)) ->
comparable_ty_eq ctxt tal tbl
>>? (fun Eq -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
|> record_inconsistent ctxt ta tb
| (Big_map_t (tal, tar, _), Big_map_t (tbl, tbr, _)) ->
comparable_ty_eq ctxt tal tbl
>>? (fun Eq -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
|> record_inconsistent ctxt ta tb
| (Set_t (ea, _), Set_t (eb, _)) ->
comparable_ty_eq ctxt ea eb
>>? (fun Eq -> ok Eq ctxt 1)
|> record_inconsistent ctxt ta tb
| ( Pair_t ((tal, _, _), (tar, _, _), _, _),
Pair_t ((tbl, _, _), (tbr, _, _), _, _) ) ->
ty_eq ctxt tal tbl
>>? (fun (Eq, ctxt) ->
ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
|> record_inconsistent ctxt ta tb
| (Union_t ((tal, _), (tar, _), _, _), Union_t ((tbl, _), (tbr, _), _, _)) ->
ty_eq ctxt tal tbl
>>? (fun (Eq, ctxt) ->
ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
|> record_inconsistent ctxt ta tb
| (Lambda_t (tal, tar, _), Lambda_t (tbl, tbr, _)) ->
ty_eq ctxt tal tbl
>>? (fun (Eq, ctxt) ->
ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
|> record_inconsistent ctxt ta tb
| (Contract_t (tal, _), Contract_t (tbl, _)) ->
ty_eq ctxt tal tbl
>>? (fun (Eq, ctxt) -> ok Eq ctxt 1)
|> record_inconsistent ctxt ta tb
| (Option_t (tva, _, _), Option_t (tvb, _, _)) ->
ty_eq ctxt tva tvb
>>? (fun (Eq, ctxt) -> ok Eq ctxt 1)
|> record_inconsistent ctxt ta tb
| (List_t (tva, _, _), List_t (tvb, _, _)) ->
ty_eq ctxt tva tvb
>>? (fun (Eq, ctxt) -> ok Eq ctxt 1)
|> record_inconsistent ctxt ta tb
| (_, _) ->
serialize_ty_for_error ctxt ta
>>? fun (ta, ctxt) ->
serialize_ty_for_error ctxt tb
>>? fun (tb, _ctxt) -> error (Inconsistent_types (ta, tb))
let rec stack_ty_eq :
type ta tb.
context ->
int ->
ta stack_ty ->
tb stack_ty ->
((ta stack_ty, tb stack_ty) eq * context) tzresult =
fun ctxt lvl ta tb ->
match (ta, tb) with
| (Item_t (tva, ra, _), Item_t (tvb, rb, _)) ->
ty_eq ctxt tva tvb
|> record_trace (Bad_stack_item lvl)
>>? fun (Eq, ctxt) ->
stack_ty_eq ctxt (lvl + 1) ra rb
>>? fun (Eq, ctxt) ->
(Ok (Eq, ctxt) : ((ta stack_ty, tb stack_ty) eq * context) tzresult)
| (Empty_t, Empty_t) ->
Ok (Eq, ctxt)
| (_, _) ->
error Bad_stack_length
let merge_comparable_types :
type ta.
legacy:bool ->
ta comparable_ty ->
ta comparable_ty ->
ta comparable_ty tzresult =
fun ~legacy ta tb ->
match (ta, tb) with
| (Int_key annot_a, Int_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Int_key annot
| (Nat_key annot_a, Nat_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Nat_key annot
| (String_key annot_a, String_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b
>|? fun annot -> String_key annot
| (Bytes_key annot_a, Bytes_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bytes_key annot
| (Mutez_key annot_a, Mutez_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Mutez_key annot
| (Bool_key annot_a, Bool_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bool_key annot
| (Key_hash_key annot_a, Key_hash_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b
>|? fun annot -> Key_hash_key annot
| (Timestamp_key annot_a, Timestamp_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b
>|? fun annot -> Timestamp_key annot
| (Address_key annot_a, Address_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b
>|? fun annot -> Address_key annot
| (_, _) ->
assert false
(* FIXME: fix injectivity of some types *)
let merge_types :
type b.
legacy:bool ->
context ->
Script.location ->
b ty ->
b ty ->
(b ty * context) tzresult =
fun ~legacy ->
let rec help : type a. context -> a ty -> a ty -> (a ty * context) tzresult =
fun ctxt ty1 ty2 ->
match (ty1, ty2) with
| (Unit_t tn1, Unit_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Unit_t tname, ctxt)
| (Int_t tn1, Int_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Int_t tname, ctxt)
| (Nat_t tn1, Nat_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Nat_t tname, ctxt)
| (Key_t tn1, Key_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Key_t tname, ctxt)
| (Key_hash_t tn1, Key_hash_t tn2) ->
merge_type_annot ~legacy tn1 tn2
>|? fun tname -> (Key_hash_t tname, ctxt)
| (String_t tn1, String_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (String_t tname, ctxt)
| (Bytes_t tn1, Bytes_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Bytes_t tname, ctxt)
| (Signature_t tn1, Signature_t tn2) ->
merge_type_annot ~legacy tn1 tn2
>|? fun tname -> (Signature_t tname, ctxt)
| (Mutez_t tn1, Mutez_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Mutez_t tname, ctxt)
| (Timestamp_t tn1, Timestamp_t tn2) ->
merge_type_annot ~legacy tn1 tn2
>|? fun tname -> (Timestamp_t tname, ctxt)
| (Address_t tn1, Address_t tn2) ->
merge_type_annot ~legacy tn1 tn2
>|? fun tname -> (Address_t tname, ctxt)
| (Bool_t tn1, Bool_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Bool_t tname, ctxt)
| (Chain_id_t tn1, Chain_id_t tn2) ->
merge_type_annot ~legacy tn1 tn2
>|? fun tname -> (Chain_id_t tname, ctxt)
| (Operation_t tn1, Operation_t tn2) ->
merge_type_annot ~legacy tn1 tn2
>|? fun tname -> (Operation_t tname, ctxt)
| (Map_t (tal, tar, tn1, has_big_map), Map_t (tbl, tbr, tn2, _)) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
help ctxt tar tbr
>>? fun (value, ctxt) ->
ty_eq ctxt tar value
>>? fun (Eq, ctxt) ->
merge_comparable_types ~legacy tal tbl
>|? fun tk -> (Map_t (tk, value, tname, has_big_map), ctxt)
| (Big_map_t (tal, tar, tn1), Big_map_t (tbl, tbr, tn2)) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
help ctxt tar tbr
>>? fun (value, ctxt) ->
ty_eq ctxt tar value
>>? fun (Eq, ctxt) ->
merge_comparable_types ~legacy tal tbl
>|? fun tk -> (Big_map_t (tk, value, tname), ctxt)
| (Set_t (ea, tn1), Set_t (eb, tn2)) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
merge_comparable_types ~legacy ea eb
>|? fun e -> (Set_t (e, tname), ctxt)
| ( Pair_t
((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1, has_big_map),
Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2, _) ) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
merge_field_annot ~legacy l_field1 l_field2
>>? fun l_field ->
merge_field_annot ~legacy r_field1 r_field2
>>? fun r_field ->
let l_var = merge_var_annot l_var1 l_var2 in
let r_var = merge_var_annot r_var1 r_var2 in
help ctxt tal tbl
>>? fun (left_ty, ctxt) ->
help ctxt tar tbr
>|? fun (right_ty, ctxt) ->
( Pair_t
( (left_ty, l_field, l_var),
(right_ty, r_field, r_var),
tname,
has_big_map ),
ctxt )
| ( Union_t ((tal, tal_annot), (tar, tar_annot), tn1, has_big_map),
Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2, _) ) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
merge_field_annot ~legacy tal_annot tbl_annot
>>? fun left_annot ->
merge_field_annot ~legacy tar_annot tbr_annot
>>? fun right_annot ->
help ctxt tal tbl
>>? fun (left_ty, ctxt) ->
help ctxt tar tbr
>|? fun (right_ty, ctxt) ->
( Union_t
((left_ty, left_annot), (right_ty, right_annot), tname, has_big_map),
ctxt )
| (Lambda_t (tal, tar, tn1), Lambda_t (tbl, tbr, tn2)) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
help ctxt tal tbl
>>? fun (left_ty, ctxt) ->
help ctxt tar tbr
>|? fun (right_ty, ctxt) -> (Lambda_t (left_ty, right_ty, tname), ctxt)
| (Contract_t (tal, tn1), Contract_t (tbl, tn2)) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
help ctxt tal tbl
>|? fun (arg_ty, ctxt) -> (Contract_t (arg_ty, tname), ctxt)
| (Option_t (tva, tn1, has_big_map), Option_t (tvb, tn2, _)) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
help ctxt tva tvb
>|? fun (ty, ctxt) -> (Option_t (ty, tname, has_big_map), ctxt)
| (List_t (tva, tn1, has_big_map), List_t (tvb, tn2, _)) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
help ctxt tva tvb
>|? fun (ty, ctxt) -> (List_t (ty, tname, has_big_map), ctxt)
| (_, _) ->
assert false
in
fun ctxt loc ty1 ty2 ->
record_inconsistent_type_annotations ctxt loc ty1 ty2 (help ctxt ty1 ty2)
let merge_stacks :
type ta.
legacy:bool ->
Script.location ->
context ->
ta stack_ty ->
ta stack_ty ->
(ta stack_ty * context) tzresult =
fun ~legacy loc ->
let rec help :
type a.
context -> a stack_ty -> a stack_ty -> (a stack_ty * context) tzresult =
fun ctxt stack1 stack2 ->
match (stack1, stack2) with
| (Empty_t, Empty_t) ->
ok (Empty_t, ctxt)
| (Item_t (ty1, rest1, annot1), Item_t (ty2, rest2, annot2)) ->
let annot = merge_var_annot annot1 annot2 in
merge_types ~legacy ctxt loc ty1 ty2
>>? fun (ty, ctxt) ->
help ctxt rest1 rest2
>|? fun (rest, ctxt) -> (Item_t (ty, rest, annot), ctxt)
in
help
let has_big_map : type t. t ty -> bool = function
| Unit_t _ ->
false
| Int_t _ ->
false
| Nat_t _ ->
false
| Signature_t _ ->
false
| String_t _ ->
false
| Bytes_t _ ->
false
| Mutez_t _ ->
false
| Key_hash_t _ ->
false
| Key_t _ ->
false
| Timestamp_t _ ->
false
| Address_t _ ->
false
| Bool_t _ ->
false
| Lambda_t (_, _, _) ->
false
| Set_t (_, _) ->
false
| Big_map_t (_, _, _) ->
true
| Contract_t (_, _) ->
false
| Operation_t _ ->
false
| Chain_id_t _ ->
false
| Pair_t (_, _, _, has_big_map) ->
has_big_map
| Union_t (_, _, _, has_big_map) ->
has_big_map
| Option_t (_, _, has_big_map) ->
has_big_map
| List_t (_, _, has_big_map) ->
has_big_map
| Map_t (_, _, _, has_big_map) ->
has_big_map
(* ---- Type checker results -------------------------------------------------*)
type 'bef judgement =
| Typed : ('bef, 'aft) descr -> 'bef judgement
| Failed : {
descr : 'aft. 'aft stack_ty -> ('bef, 'aft) descr;
}
-> 'bef judgement
(* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*)
type ('t, 'f, 'b) branch = {
branch : 'r. ('t, 'r) descr -> ('f, 'r) descr -> ('b, 'r) descr;
}
[@@unboxed]
let merge_branches :
type bef a b.
legacy:bool ->
context ->
int ->
a judgement ->
b judgement ->
(a, b, bef) branch ->
(bef judgement * context) tzresult Lwt.t =
fun ~legacy ctxt loc btr bfr {branch} ->
match (btr, bfr) with
| (Typed ({aft = aftbt; _} as dbt), Typed ({aft = aftbf; _} as dbf)) ->
let unmatched_branches () =
serialize_stack_for_error ctxt aftbt
>>=? fun (aftbt, ctxt) ->
serialize_stack_for_error ctxt aftbf
>>|? fun (aftbf, _ctxt) -> Unmatched_branches (loc, aftbt, aftbf)
in
trace_eval
unmatched_branches
( Lwt.return (stack_ty_eq ctxt 1 aftbt aftbf)
>>=? fun (Eq, ctxt) ->
Lwt.return (merge_stacks ~legacy loc ctxt aftbt aftbf)
>>=? fun (merged_stack, ctxt) ->
return
( Typed
(branch
{dbt with aft = merged_stack}
{dbf with aft = merged_stack}),
ctxt ) )
| (Failed {descr = descrt}, Failed {descr = descrf}) ->
let descr ret = branch (descrt ret) (descrf ret) in
return (Failed {descr}, ctxt)
| (Typed dbt, Failed {descr = descrf}) ->
return (Typed (branch dbt (descrf dbt.aft)), ctxt)
| (Failed {descr = descrt}, Typed dbf) ->
return (Typed (branch (descrt dbf.aft) dbf), ctxt)
let rec parse_comparable_ty :
context -> Script.node -> (ex_comparable_ty * context) tzresult =
fun ctxt ty ->
Gas.consume ctxt Typecheck_costs.cycle
>>? fun ctxt ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>>? fun ctxt ->
match ty with
| Prim (loc, T_int, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Int_key tname), ctxt)
| Prim (loc, T_nat, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Nat_key tname), ctxt)
| Prim (loc, T_string, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (String_key tname), ctxt)
| Prim (loc, T_bytes, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Bytes_key tname), ctxt)
| Prim (loc, T_mutez, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Mutez_key tname), ctxt)
| Prim (loc, T_bool, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Bool_key tname), ctxt)
| Prim (loc, T_key_hash, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Key_hash_key tname), ctxt)
| Prim (loc, T_timestamp, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Timestamp_key tname), ctxt)
| Prim (loc, T_address, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Address_key tname), ctxt)
| Prim
( loc,
( ( T_int
| T_nat
| T_string
| T_mutez
| T_bool
| T_key
| T_address
| T_timestamp ) as prim ),
l,
_ ) ->
error (Invalid_arity (loc, prim, 0, List.length l))
| Prim
( loc,
( T_pair
| T_or
| T_set
| T_map
| T_list
| T_option
| T_lambda
| T_unit
| T_signature
| T_contract ),
_,
_ ) ->
error (Comparable_type_expected (loc, Micheline.strip_locations ty))
| expr ->
error
@@ unexpected
expr
[]
Type_namespace
[ T_int;
T_nat;
T_string;
T_mutez;
T_bool;
T_key;
T_key_hash;
T_timestamp ]
and parse_packable_ty :
context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
fun ctxt ~legacy ->
parse_ty
ctxt
~legacy
~allow_big_map:false
~allow_operation:false
~allow_contract:legacy
and parse_parameter_ty :
context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
fun ctxt ~legacy ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:true
and parse_any_ty :
context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
fun ctxt ~legacy ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:true
~allow_contract:true
and parse_ty :
context ->
legacy:bool ->
allow_big_map:bool ->
allow_operation:bool ->
allow_contract:bool ->
Script.node ->
(ex_ty * context) tzresult =
fun ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract node ->
Gas.consume ctxt Typecheck_costs.cycle
>>? fun ctxt ->
match node with
| Prim (loc, T_unit, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Unit_t ty_name), ctxt)
| Prim (loc, T_int, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Int_t ty_name), ctxt)
| Prim (loc, T_nat, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Nat_t ty_name), ctxt)
| Prim (loc, T_string, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (String_t ty_name), ctxt)
| Prim (loc, T_bytes, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Bytes_t ty_name), ctxt)
| Prim (loc, T_mutez, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Mutez_t ty_name), ctxt)
| Prim (loc, T_bool, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Bool_t ty_name), ctxt)
| Prim (loc, T_key, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Key_t ty_name), ctxt)
| Prim (loc, T_key_hash, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Key_hash_t ty_name), ctxt)
| Prim (loc, T_timestamp, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Timestamp_t ty_name), ctxt)
| Prim (loc, T_address, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Address_t ty_name), ctxt)
| Prim (loc, T_signature, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Signature_t ty_name), ctxt)
| Prim (loc, T_operation, [], annot) ->
if allow_operation then
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Operation_t ty_name), ctxt)
else error (Unexpected_operation loc)
| Prim (loc, T_chain_id, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Chain_id_t ty_name), ctxt)
| Prim (loc, T_contract, [utl], annot) ->
if allow_contract then
parse_parameter_ty ctxt ~legacy utl
>>? fun (Ex_ty tl, ctxt) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 1)
>|? fun ctxt -> (Ex_ty (Contract_t (tl, ty_name)), ctxt)
else error (Unexpected_contract loc)
| Prim (loc, T_pair, [utl; utr], annot) ->
extract_field_annot utl
>>? fun (utl, left_field) ->
extract_field_annot utr
>>? fun (utr, right_field) ->
parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl
>>? fun (Ex_ty tl, ctxt) ->
parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr
>>? fun (Ex_ty tr, ctxt) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 2)
>|? fun ctxt ->
( Ex_ty
(Pair_t
( (tl, left_field, None),
(tr, right_field, None),
ty_name,
has_big_map tl || has_big_map tr )),
ctxt )
| Prim (loc, T_or, [utl; utr], annot) ->
extract_field_annot utl
>>? fun (utl, left_constr) ->
extract_field_annot utr
>>? fun (utr, right_constr) ->
parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl
>>? fun (Ex_ty tl, ctxt) ->
parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr
>>? fun (Ex_ty tr, ctxt) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 2)
>|? fun ctxt ->
( Ex_ty
(Union_t
( (tl, left_constr),
(tr, right_constr),
ty_name,
has_big_map tl || has_big_map tr )),
ctxt )
| Prim (loc, T_lambda, [uta; utr], annot) ->
parse_any_ty ctxt ~legacy uta
>>? fun (Ex_ty ta, ctxt) ->
parse_any_ty ctxt ~legacy utr
>>? fun (Ex_ty tr, ctxt) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 2)
>|? fun ctxt -> (Ex_ty (Lambda_t (ta, tr, ty_name)), ctxt)
| Prim (loc, T_option, [ut], annot) ->
( if legacy then
(* legacy semantics with (broken) field annotations *)
extract_field_annot ut
>>? fun (ut, _some_constr) ->
parse_composed_type_annot loc annot
>>? fun (ty_name, _none_constr, _) -> ok (ut, ty_name)
else parse_type_annot loc annot >>? fun ty_name -> ok (ut, ty_name) )
>>? fun (ut, ty_name) ->
parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut
>>? fun (Ex_ty t, ctxt) ->
Gas.consume ctxt (Typecheck_costs.type_ 2)
>|? fun ctxt -> (Ex_ty (Option_t (t, ty_name, has_big_map t)), ctxt)
| Prim (loc, T_list, [ut], annot) ->
parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut
>>? fun (Ex_ty t, ctxt) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 1)
>|? fun ctxt -> (Ex_ty (List_t (t, ty_name, has_big_map t)), ctxt)
| Prim (loc, T_set, [ut], annot) ->
parse_comparable_ty ctxt ut
>>? fun (Ex_comparable_ty t, ctxt) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 1)
>|? fun ctxt -> (Ex_ty (Set_t (t, ty_name)), ctxt)
| Prim (loc, T_map, [uta; utr], annot) ->
parse_comparable_ty ctxt uta
>>? fun (Ex_comparable_ty ta, ctxt) ->
parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr
>>? fun (Ex_ty tr, ctxt) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 2)
>|? fun ctxt -> (Ex_ty (Map_t (ta, tr, ty_name, has_big_map tr)), ctxt)
| Prim (loc, T_big_map, args, annot) when allow_big_map ->
parse_big_map_ty ctxt ~legacy loc args annot
>>? fun (big_map_ty, ctxt) ->
Gas.consume ctxt (Typecheck_costs.type_ 2)
>|? fun ctxt -> (big_map_ty, ctxt)
| Prim (loc, T_big_map, _, _) ->
error (Unexpected_big_map loc)
| Prim
( loc,
( ( T_unit
| T_signature
| T_int
| T_nat
| T_string
| T_bytes
| T_mutez
| T_bool
| T_key
| T_key_hash
| T_timestamp
| T_address ) as prim ),
l,
_ ) ->
error (Invalid_arity (loc, prim, 0, List.length l))
| Prim (loc, ((T_set | T_list | T_option | T_contract) as prim), l, _) ->
error (Invalid_arity (loc, prim, 1, List.length l))
| Prim (loc, ((T_pair | T_or | T_map | T_lambda) as prim), l, _) ->
error (Invalid_arity (loc, prim, 2, List.length l))
| expr ->
error
@@ unexpected
expr
[]
Type_namespace
[ T_pair;
T_or;
T_set;
T_map;
T_list;
T_option;
T_lambda;
T_unit;
T_signature;
T_contract;
T_int;
T_nat;
T_operation;
T_string;
T_bytes;
T_mutez;
T_bool;
T_key;
T_key_hash;
T_timestamp;
T_chain_id ]
and parse_big_map_ty ctxt ~legacy big_map_loc args map_annot =
Gas.consume ctxt Typecheck_costs.cycle
>>? fun ctxt ->
match args with
| [key_ty; value_ty] ->
parse_comparable_ty ctxt key_ty
>>? fun (Ex_comparable_ty key_ty, ctxt) ->
parse_packable_ty ctxt ~legacy value_ty
>>? fun (Ex_ty value_ty, ctxt) ->
parse_type_annot big_map_loc map_annot
>|? fun map_name ->
let big_map_ty = Big_map_t (key_ty, value_ty, map_name) in
(Ex_ty big_map_ty, ctxt)
| args ->
error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args)
and parse_storage_ty :
context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
fun ctxt ~legacy node ->
match node with
| Prim
( loc,
T_pair,
[Prim (big_map_loc, T_big_map, args, map_annot); remaining_storage],
storage_annot )
when legacy -> (
match storage_annot with
| [] ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:legacy
node
| [single]
when Compare.Int.(String.length single > 0)
&& Compare.Char.(single.[0] = '%') ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:legacy
node
| _ ->
(* legacy semantics of big maps used the wrong annotation parser *)
Gas.consume ctxt Typecheck_costs.cycle
>>? fun ctxt ->
parse_big_map_ty ctxt ~legacy big_map_loc args map_annot
>>? fun (Ex_ty big_map_ty, ctxt) ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:legacy
remaining_storage
>>? fun (Ex_ty remaining_storage, ctxt) ->
parse_composed_type_annot loc storage_annot
>>? fun (ty_name, map_field, storage_field) ->
Gas.consume ctxt (Typecheck_costs.type_ 5)
>|? fun ctxt ->
( Ex_ty
(Pair_t
( (big_map_ty, map_field, None),
(remaining_storage, storage_field, None),
ty_name,
true )),
ctxt ) )
| _ ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:legacy
node
let check_packable ~legacy loc root =
let rec check : type t. t ty -> unit tzresult = function
| Big_map_t _ ->
error (Unexpected_big_map loc)
| Operation_t _ ->
error (Unexpected_operation loc)
| Unit_t _ ->
ok ()
| Int_t _ ->
ok ()
| Nat_t _ ->
ok ()
| Signature_t _ ->
ok ()
| String_t _ ->
ok ()
| Bytes_t _ ->
ok ()
| Mutez_t _ ->
ok ()
| Key_hash_t _ ->
ok ()
| Key_t _ ->
ok ()
| Timestamp_t _ ->
ok ()
| Address_t _ ->
ok ()
| Bool_t _ ->
ok ()
| Chain_id_t _ ->
ok ()
| Pair_t ((l_ty, _, _), (r_ty, _, _), _, _) ->
check l_ty >>? fun () -> check r_ty
| Union_t ((l_ty, _), (r_ty, _), _, _) ->
check l_ty >>? fun () -> check r_ty
| Option_t (v_ty, _, _) ->
check v_ty
| List_t (elt_ty, _, _) ->
check elt_ty
| Set_t (_, _) ->
ok ()
| Map_t (_, elt_ty, _, _) ->
check elt_ty
| Lambda_t (_l_ty, _r_ty, _) ->
ok ()
| Contract_t (_, _) when legacy ->
ok ()
| Contract_t (_, _) ->
error (Unexpected_contract loc)
in
check root
type ex_script = Ex_script : ('a, 'c) script -> ex_script
type _ dig_proof_argument =
| Dig_proof_argument :
( ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness
* ('x ty * var_annot option)
* 'aft stack_ty )
-> 'bef dig_proof_argument
type (_, _) dug_proof_argument =
| Dug_proof_argument :
( ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness
* unit
* 'aft stack_ty )
-> ('bef, 'x) dug_proof_argument
type _ dipn_proof_argument =
| Dipn_proof_argument :
( ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness
* (context * ('fbef, 'faft) descr)
* 'aft stack_ty )
-> 'bef dipn_proof_argument
type _ dropn_proof_argument =
| Dropn_proof_argument :
( ('rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness
* 'rest stack_ty
* 'aft stack_ty )
-> 'bef dropn_proof_argument
(* Lwt versions *)
let parse_var_annot loc ?default annot =
Lwt.return (parse_var_annot loc ?default annot)
let parse_entrypoint_annot loc ?default annot =
Lwt.return (parse_entrypoint_annot loc ?default annot)
let parse_constr_annot loc ?if_special_first ?if_special_second annot =
Lwt.return
(parse_constr_annot loc ?if_special_first ?if_special_second annot)
let parse_two_var_annot loc annot = Lwt.return (parse_two_var_annot loc annot)
let parse_destr_annot loc annot ~default_accessor ~field_name ~pair_annot
~value_annot =
Lwt.return
(parse_destr_annot
loc
annot
~default_accessor
~field_name
~pair_annot
~value_annot)
let parse_var_type_annot loc annot =
Lwt.return (parse_var_type_annot loc annot)
let find_entrypoint (type full) (full : full ty) ~root_name entrypoint =
let rec find_entrypoint :
type t. t ty -> string -> (Script.node -> Script.node) * ex_ty =
fun t entrypoint ->
match t with
| Union_t ((tl, al), (tr, ar), _, _) -> (
if
match al with
| None ->
false
| Some (`Field_annot l) ->
Compare.String.(l = entrypoint)
then ((fun e -> Prim (0, D_Left, [e], [])), Ex_ty tl)
else if
match ar with
| None ->
false
| Some (`Field_annot r) ->
Compare.String.(r = entrypoint)
then ((fun e -> Prim (0, D_Right, [e], [])), Ex_ty tr)
else
try
let (f, t) = find_entrypoint tl entrypoint in
((fun e -> Prim (0, D_Left, [f e], [])), t)
with Not_found ->
let (f, t) = find_entrypoint tr entrypoint in
((fun e -> Prim (0, D_Right, [f e], [])), t) )
| _ ->
raise Not_found
in
let entrypoint =
if Compare.String.(entrypoint = "") then "default" else entrypoint
in
if Compare.Int.(String.length entrypoint > 31) then
error (Entrypoint_name_too_long entrypoint)
else
match root_name with
| Some root_name when Compare.String.(entrypoint = root_name) ->
ok ((fun e -> e), Ex_ty full)
| _ -> (
try ok (find_entrypoint full entrypoint)
with Not_found -> (
match entrypoint with
| "default" ->
ok ((fun e -> e), Ex_ty full)
| _ ->
error (No_such_entrypoint entrypoint) ) )
let find_entrypoint_for_type (type full exp) ~(full : full ty)
~(expected : exp ty) ~root_name entrypoint ctxt :
(context * string * exp ty) tzresult =
match (entrypoint, root_name) with
| ("default", Some "root") -> (
match find_entrypoint full ~root_name entrypoint with
| Error _ as err ->
err
| Ok (_, Ex_ty ty) -> (
match ty_eq ctxt expected ty with
| Ok (Eq, ctxt) ->
ok (ctxt, "default", (ty : exp ty))
| Error _ ->
ty_eq ctxt expected full
>>? fun (Eq, ctxt) -> ok (ctxt, "root", (full : exp ty)) ) )
| _ ->
find_entrypoint full ~root_name entrypoint
>>? fun (_, Ex_ty ty) ->
ty_eq ctxt expected ty
>>? fun (Eq, ctxt) -> ok (ctxt, entrypoint, (ty : exp ty))
module Entrypoints = Set.Make (String)
exception Duplicate of string
exception Too_long of string
let well_formed_entrypoints (type full) (full : full ty) ~root_name =
let merge path annot (type t) (ty : t ty) reachable
((first_unreachable, all) as acc) =
match annot with
| None | Some (`Field_annot "") -> (
if reachable then acc
else
match ty with
| Union_t _ ->
acc
| _ -> (
match first_unreachable with
| None ->
(Some (List.rev path), all)
| Some _ ->
acc ) )
| Some (`Field_annot name) ->
if Compare.Int.(String.length name > 31) then raise (Too_long name)
else if Entrypoints.mem name all then raise (Duplicate name)
else (first_unreachable, Entrypoints.add name all)
in
let rec check :
type t.
t ty ->
prim list ->
bool ->
prim list option * Entrypoints.t ->
prim list option * Entrypoints.t =
fun t path reachable acc ->
match t with
| Union_t ((tl, al), (tr, ar), _, _) ->
let acc = merge (D_Left :: path) al tl reachable acc in
let acc = merge (D_Right :: path) ar tr reachable acc in
let acc =
check
tl
(D_Left :: path)
(match al with Some _ -> true | None -> reachable)
acc
in
check
tr
(D_Right :: path)
(match ar with Some _ -> true | None -> reachable)
acc
| _ ->
acc
in
try
let (init, reachable) =
match root_name with
| None | Some "" ->
(Entrypoints.empty, false)
| Some name ->
(Entrypoints.singleton name, true)
in
let (first_unreachable, all) = check full [] reachable (None, init) in
if not (Entrypoints.mem "default" all) then ok ()
else
match first_unreachable with
| None ->
ok ()
| Some path ->
error (Unreachable_entrypoint path)
with
| Duplicate name ->
error (Duplicate_entrypoint name)
| Too_long name ->
error (Entrypoint_name_too_long name)
let rec parse_data :
type a.
?type_logger:type_logger ->
context ->
legacy:bool ->
a ty ->
Script.node ->
(a * context) tzresult Lwt.t =
fun ?type_logger ctxt ~legacy ty script_data ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
let error () =
Lwt.return (serialize_ty_for_error ctxt ty)
>>|? fun (ty, _ctxt) ->
Invalid_constant (location script_data, strip_locations script_data, ty)
in
let traced body = trace_eval error body in
let parse_items ?type_logger loc ctxt expr key_type value_type items
item_wrapper =
let length = List.length items in
fold_left_s
(fun (last_value, map, ctxt) item ->
Lwt.return (Gas.consume ctxt (Typecheck_costs.map_element length))
>>=? fun ctxt ->
match item with
| Prim (_, D_Elt, [k; v], _) ->
parse_comparable_data ?type_logger ctxt key_type k
>>=? fun (k, ctxt) ->
parse_data ?type_logger ctxt ~legacy value_type v
>>=? fun (v, ctxt) ->
( match last_value with
| Some value ->
if Compare.Int.(0 <= compare_comparable key_type value k) then
if Compare.Int.(0 = compare_comparable key_type value k) then
fail (Duplicate_map_keys (loc, strip_locations expr))
else fail (Unordered_map_keys (loc, strip_locations expr))
else return_unit
| None ->
return_unit )
>>=? fun () ->
return (Some k, map_update k (Some (item_wrapper v)) map, ctxt)
| Prim (loc, D_Elt, l, _) ->
fail @@ Invalid_arity (loc, D_Elt, 2, List.length l)
| Prim (loc, name, _, _) ->
fail @@ Invalid_primitive (loc, [D_Elt], name)
| Int _ | String _ | Bytes _ | Seq _ ->
error () >>=? fail)
(None, empty_map key_type, ctxt)
items
|> traced
>>|? fun (_, items, ctxt) -> (items, ctxt)
in
match (ty, script_data) with
(* Unit *)
| (Unit_t _, Prim (loc, D_Unit, [], annot)) ->
(if legacy then return () else fail_unexpected_annot loc annot)
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.unit)
>>|? fun ctxt -> ((() : a), ctxt)
| (Unit_t _, Prim (loc, D_Unit, l, _)) ->
traced (fail (Invalid_arity (loc, D_Unit, 0, List.length l)))
| (Unit_t _, expr) ->
traced (fail (unexpected expr [] Constant_namespace [D_Unit]))
(* Booleans *)
| (Bool_t _, Prim (loc, D_True, [], annot)) ->
(if legacy then return () else fail_unexpected_annot loc annot)
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.bool)
>>|? fun ctxt -> (true, ctxt)
| (Bool_t _, Prim (loc, D_False, [], annot)) ->
(if legacy then return () else fail_unexpected_annot loc annot)
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.bool)
>>|? fun ctxt -> (false, ctxt)
| (Bool_t _, Prim (loc, ((D_True | D_False) as c), l, _)) ->
traced (fail (Invalid_arity (loc, c, 0, List.length l)))
| (Bool_t _, expr) ->
traced (fail (unexpected expr [] Constant_namespace [D_True; D_False]))
(* Strings *)
| (String_t _, String (_, v)) ->
Lwt.return (Gas.consume ctxt (Typecheck_costs.string (String.length v)))
>>=? fun ctxt ->
let rec check_printable_ascii i =
if Compare.Int.(i < 0) then true
else
match v.[i] with
| '\n' | '\x20' .. '\x7E' ->
check_printable_ascii (i - 1)
| _ ->
false
in
if check_printable_ascii (String.length v - 1) then return (v, ctxt)
else error () >>=? fail
| (String_t _, expr) ->
traced (fail (Invalid_kind (location expr, [String_kind], kind expr)))
(* Byte sequences *)
| (Bytes_t _, Bytes (_, v)) ->
Lwt.return (Gas.consume ctxt (Typecheck_costs.string (MBytes.length v)))
>>=? fun ctxt -> return (v, ctxt)
| (Bytes_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Bytes_kind], kind expr)))
(* Integers *)
| (Int_t _, Int (_, v)) ->
Lwt.return (Gas.consume ctxt (Typecheck_costs.z v))
>>=? fun ctxt -> return (Script_int.of_zint v, ctxt)
| (Nat_t _, Int (_, v)) ->
Lwt.return (Gas.consume ctxt (Typecheck_costs.z v))
>>=? fun ctxt ->
let v = Script_int.of_zint v in
if Compare.Int.(Script_int.compare v Script_int.zero >= 0) then
return (Script_int.abs v, ctxt)
else error () >>=? fail
| (Int_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Int_kind], kind expr)))
| (Nat_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Int_kind], kind expr)))
(* Tez amounts *)
| (Mutez_t _, Int (_, v)) -> (
Lwt.return
( Gas.consume ctxt Typecheck_costs.tez
>>? fun ctxt ->
Gas.consume ctxt Michelson_v1_gas.Cost_of.Legacy.z_to_int64 )
>>=? fun ctxt ->
try
match Tez.of_mutez (Z.to_int64 v) with
| None ->
raise Exit
| Some tez ->
return (tez, ctxt)
with _ -> error () >>=? fail )
| (Mutez_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Int_kind], kind expr)))
(* Timestamps *)
| (Timestamp_t _, Int (_, v))
(* As unparsed with [Optimized] or out of bounds [Readable]. *) ->
Lwt.return (Gas.consume ctxt (Typecheck_costs.z v))
>>=? fun ctxt -> return (Script_timestamp.of_zint v, ctxt)
| (Timestamp_t _, String (_, s)) (* As unparsed with [Redable]. *) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp)
>>=? fun ctxt ->
match Script_timestamp.of_string s with
| Some v ->
return (v, ctxt)
| None ->
error () >>=? fail )
| (Timestamp_t _, expr) ->
traced
(fail
(Invalid_kind (location expr, [String_kind; Int_kind], kind expr)))
(* IDs *)
| (Key_t _, Bytes (_, bytes)) -> (
(* As unparsed with [Optimized]. *)
Lwt.return (Gas.consume ctxt Typecheck_costs.key)
>>=? fun ctxt ->
match
Data_encoding.Binary.of_bytes Signature.Public_key.encoding bytes
with
| Some k ->
return (k, ctxt)
| None ->
error () >>=? fail )
| (Key_t _, String (_, s)) -> (
(* As unparsed with [Readable]. *)
Lwt.return (Gas.consume ctxt Typecheck_costs.key)
>>=? fun ctxt ->
match Signature.Public_key.of_b58check_opt s with
| Some k ->
return (k, ctxt)
| None ->
error () >>=? fail )
| (Key_t _, expr) ->
traced
(fail
(Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
| (Key_hash_t _, Bytes (_, bytes)) -> (
(* As unparsed with [Optimized]. *)
Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash)
>>=? fun ctxt ->
match
Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding bytes
with
| Some k ->
return (k, ctxt)
| None ->
error () >>=? fail )
| (Key_hash_t _, String (_, s)) (* As unparsed with [Readable]. *) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash)
>>=? fun ctxt ->
match Signature.Public_key_hash.of_b58check_opt s with
| Some k ->
return (k, ctxt)
| None ->
error () >>=? fail )
| (Key_hash_t _, expr) ->
traced
(fail
(Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
(* Signatures *)
| (Signature_t _, Bytes (_, bytes)) (* As unparsed with [Optimized]. *) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.signature)
>>=? fun ctxt ->
match Data_encoding.Binary.of_bytes Signature.encoding bytes with
| Some k ->
return (k, ctxt)
| None ->
error () >>=? fail )
| (Signature_t _, String (_, s)) (* As unparsed with [Readable]. *) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.signature)
>>=? fun ctxt ->
match Signature.of_b58check_opt s with
| Some s ->
return (s, ctxt)
| None ->
error () >>=? fail )
| (Signature_t _, expr) ->
traced
(fail
(Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
(* Operations *)
| (Operation_t _, _) ->
(* operations cannot appear in parameters or storage,
the protocol should never parse the bytes of an operation *)
assert false
(* Chain_ids *)
| (Chain_id_t _, Bytes (_, bytes)) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id)
>>=? fun ctxt ->
match Data_encoding.Binary.of_bytes Chain_id.encoding bytes with
| Some k ->
return (k, ctxt)
| None ->
error () >>=? fail )
| (Chain_id_t _, String (_, s)) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id)
>>=? fun ctxt ->
match Chain_id.of_b58check_opt s with
| Some s ->
return (s, ctxt)
| None ->
error () >>=? fail )
| (Chain_id_t _, expr) ->
traced
(fail
(Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
(* Addresses *)
| (Address_t _, Bytes (loc, bytes)) (* As unparsed with [O[ptimized]. *) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
>>=? fun ctxt ->
match
Data_encoding.Binary.of_bytes
Data_encoding.(tup2 Contract.encoding Variable.string)
bytes
with
| Some (c, entrypoint) ->
if Compare.Int.(String.length entrypoint > 31) then
fail (Entrypoint_name_too_long entrypoint)
else
( match entrypoint with
| "" ->
return "default"
| "default" ->
fail (Unexpected_annotation loc)
| name ->
return name )
>>=? fun entrypoint -> return ((c, entrypoint), ctxt)
| None ->
error () >>=? fail )
| (Address_t _, String (loc, s)) (* As unparsed with [Readable]. *) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
>>=? fun ctxt ->
( match String.index_opt s '%' with
| None ->
return (s, "default")
| Some pos -> (
let len = String.length s - pos - 1 in
let name = String.sub s (pos + 1) len in
if Compare.Int.(len > 31) then fail (Entrypoint_name_too_long name)
else
match (String.sub s 0 pos, name) with
| (_, "default") ->
traced (fail (Unexpected_annotation loc))
| addr_and_name ->
return addr_and_name ) )
>>=? fun (addr, entrypoint) ->
Lwt.return (Contract.of_b58check addr)
>>=? fun c -> return ((c, entrypoint), ctxt)
| (Address_t _, expr) ->
traced
(fail
(Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
(* Contracts *)
| (Contract_t (ty, _), Bytes (loc, bytes))
(* As unparsed with [Optimized]. *) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
>>=? fun ctxt ->
match
Data_encoding.Binary.of_bytes
Data_encoding.(tup2 Contract.encoding Variable.string)
bytes
with
| Some (c, entrypoint) ->
if Compare.Int.(String.length entrypoint > 31) then
fail (Entrypoint_name_too_long entrypoint)
else
( match entrypoint with
| "" ->
return "default"
| "default" ->
traced (fail (Unexpected_annotation loc))
| name ->
return name )
>>=? fun entrypoint ->
traced (parse_contract ~legacy ctxt loc ty c ~entrypoint)
>>=? fun (ctxt, _) -> return ((ty, (c, entrypoint)), ctxt)
| None ->
error () >>=? fail )
| (Contract_t (ty, _), String (loc, s)) (* As unparsed with [Readable]. *) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
>>=? fun ctxt ->
( match String.index_opt s '%' with
| None ->
return (s, "default")
| Some pos -> (
let len = String.length s - pos - 1 in
let name = String.sub s (pos + 1) len in
if Compare.Int.(len > 31) then fail (Entrypoint_name_too_long name)
else
match (String.sub s 0 pos, name) with
| (_, "default") ->
traced (fail (Unexpected_annotation loc))
| addr_and_name ->
return addr_and_name ) )
>>=? fun (addr, entrypoint) ->
traced (Lwt.return (Contract.of_b58check addr))
>>=? fun c ->
parse_contract ~legacy ctxt loc ty c ~entrypoint
>>=? fun (ctxt, _) -> return ((ty, (c, entrypoint)), ctxt)
| (Contract_t _, expr) ->
traced
(fail
(Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
(* Pairs *)
| (Pair_t ((ta, _, _), (tb, _, _), _, _), Prim (loc, D_Pair, [va; vb], annot))
->
(if legacy then return () else fail_unexpected_annot loc annot)
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.pair)
>>=? fun ctxt ->
traced @@ parse_data ?type_logger ctxt ~legacy ta va
>>=? fun (va, ctxt) ->
parse_data ?type_logger ctxt ~legacy tb vb
>>=? fun (vb, ctxt) -> return ((va, vb), ctxt)
| (Pair_t _, Prim (loc, D_Pair, l, _)) ->
fail @@ Invalid_arity (loc, D_Pair, 2, List.length l)
| (Pair_t _, expr) ->
traced (fail (unexpected expr [] Constant_namespace [D_Pair]))
(* Unions *)
| (Union_t ((tl, _), _, _, _), Prim (loc, D_Left, [v], annot)) ->
(if legacy then return () else fail_unexpected_annot loc annot)
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.union)
>>=? fun ctxt ->
traced @@ parse_data ?type_logger ctxt ~legacy tl v
>>=? fun (v, ctxt) -> return (L v, ctxt)
| (Union_t _, Prim (loc, D_Left, l, _)) ->
fail @@ Invalid_arity (loc, D_Left, 1, List.length l)
| (Union_t (_, (tr, _), _, _), Prim (loc, D_Right, [v], annot)) ->
fail_unexpected_annot loc annot
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.union)
>>=? fun ctxt ->
traced @@ parse_data ?type_logger ctxt ~legacy tr v
>>=? fun (v, ctxt) -> return (R v, ctxt)
| (Union_t _, Prim (loc, D_Right, l, _)) ->
fail @@ Invalid_arity (loc, D_Right, 1, List.length l)
| (Union_t _, expr) ->
traced (fail (unexpected expr [] Constant_namespace [D_Left; D_Right]))
(* Lambdas *)
| (Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr)) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.lambda)
>>=? fun ctxt ->
traced
@@ parse_returning
Lambda
?type_logger
ctxt
~legacy
(ta, Some (`Var_annot "@arg"))
tr
script_instr
| (Lambda_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
(* Options *)
| (Option_t (t, _, _), Prim (loc, D_Some, [v], annot)) ->
(if legacy then return () else fail_unexpected_annot loc annot)
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.some)
>>=? fun ctxt ->
traced @@ parse_data ?type_logger ctxt ~legacy t v
>>=? fun (v, ctxt) -> return (Some v, ctxt)
| (Option_t _, Prim (loc, D_Some, l, _)) ->
fail @@ Invalid_arity (loc, D_Some, 1, List.length l)
| (Option_t (_, _, _), Prim (loc, D_None, [], annot)) ->
(if legacy then return () else fail_unexpected_annot loc annot)
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.none)
>>=? fun ctxt -> return (None, ctxt)
| (Option_t _, Prim (loc, D_None, l, _)) ->
fail @@ Invalid_arity (loc, D_None, 0, List.length l)
| (Option_t _, expr) ->
traced (fail (unexpected expr [] Constant_namespace [D_Some; D_None]))
(* Lists *)
| (List_t (t, _ty_name, _), Seq (_loc, items)) ->
traced
@@ fold_right_s
(fun v (rest, ctxt) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.list_element)
>>=? fun ctxt ->
parse_data ?type_logger ctxt ~legacy t v
>>=? fun (v, ctxt) -> return (v :: rest, ctxt))
items
([], ctxt)
| (List_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
(* Sets *)
| (Set_t (t, _ty_name), (Seq (loc, vs) as expr)) ->
let length = List.length vs in
traced
@@ fold_left_s
(fun (last_value, set, ctxt) v ->
Lwt.return (Gas.consume ctxt (Typecheck_costs.set_element length))
>>=? fun ctxt ->
parse_comparable_data ?type_logger ctxt t v
>>=? fun (v, ctxt) ->
( match last_value with
| Some value ->
if Compare.Int.(0 <= compare_comparable t value v) then
if Compare.Int.(0 = compare_comparable t value v) then
fail (Duplicate_set_values (loc, strip_locations expr))
else fail (Unordered_set_values (loc, strip_locations expr))
else return_unit
| None ->
return_unit )
>>=? fun () ->
Lwt.return
(Gas.consume
ctxt
(Michelson_v1_gas.Cost_of.Legacy.set_update v false set))
>>=? fun ctxt -> return (Some v, set_update v true set, ctxt))
(None, empty_set t, ctxt)
vs
>>|? fun (_, set, ctxt) -> (set, ctxt)
| (Set_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
(* Maps *)
| (Map_t (tk, tv, _ty_name, _), (Seq (loc, vs) as expr)) ->
parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x)
| (Map_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
| (Big_map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr)) ->
parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x)
>>|? fun (diff, ctxt) ->
( {id = None; diff; key_type = ty_of_comparable_ty tk; value_type = tv},
ctxt )
| (Big_map_t (tk, tv, _ty_name), Int (loc, id)) -> (
Big_map.exists ctxt id
>>=? function
| (_, None) ->
traced (fail (Invalid_big_map (loc, id)))
| (ctxt, Some (btk, btv)) ->
Lwt.return
( parse_comparable_ty ctxt (Micheline.root btk)
>>? fun (Ex_comparable_ty btk, ctxt) ->
parse_packable_ty ctxt ~legacy (Micheline.root btv)
>>? fun (Ex_ty btv, ctxt) ->
comparable_ty_eq ctxt tk btk
>>? fun Eq ->
ty_eq ctxt tv btv
>>? fun (Eq, ctxt) ->
ok
( {
id = Some id;
diff = empty_map tk;
key_type = ty_of_comparable_ty tk;
value_type = tv;
},
ctxt ) ) )
| (Big_map_t (_tk, _tv, _), expr) ->
traced
(fail (Invalid_kind (location expr, [Seq_kind; Int_kind], kind expr)))
and parse_comparable_data :
type a.
?type_logger:type_logger ->
context ->
a comparable_ty ->
Script.node ->
(a * context) tzresult Lwt.t =
fun ?type_logger ctxt ty script_data ->
parse_data
?type_logger
ctxt
~legacy:false
(ty_of_comparable_ty ty)
script_data
and parse_returning :
type arg ret.
?type_logger:type_logger ->
tc_context ->
context ->
legacy:bool ->
arg ty * var_annot option ->
ret ty ->
Script.node ->
((arg, ret) lambda * context) tzresult Lwt.t =
fun ?type_logger tc_context ctxt ~legacy (arg, arg_annot) ret script_instr ->
parse_instr
?type_logger
tc_context
ctxt
~legacy
script_instr
(Item_t (arg, Empty_t, arg_annot))
>>=? function
| (Typed ({loc; aft = Item_t (ty, Empty_t, _) as stack_ty; _} as descr), ctxt)
->
trace_eval
(fun () ->
Lwt.return (serialize_ty_for_error ctxt ret)
>>=? fun (ret, ctxt) ->
serialize_stack_for_error ctxt stack_ty
>>|? fun (stack_ty, _ctxt) -> Bad_return (loc, stack_ty, ret))
( Lwt.return (ty_eq ctxt ty ret)
>>=? fun (Eq, ctxt) ->
Lwt.return (merge_types ~legacy ctxt loc ty ret)
>>=? fun (_ret, ctxt) ->
return ((Lam (descr, script_instr) : (arg, ret) lambda), ctxt) )
| (Typed {loc; aft = stack_ty; _}, ctxt) ->
Lwt.return (serialize_ty_for_error ctxt ret)
>>=? fun (ret, ctxt) ->
serialize_stack_for_error ctxt stack_ty
>>=? fun (stack_ty, _ctxt) -> fail (Bad_return (loc, stack_ty, ret))
| (Failed {descr}, ctxt) ->
return
( ( Lam (descr (Item_t (ret, Empty_t, None)), script_instr)
: (arg, ret) lambda ),
ctxt )
and parse_int32 (n : (location, prim) Micheline.node) : int tzresult =
let error' () =
Invalid_syntactic_constant
( location n,
strip_locations n,
"a positive 32-bit integer (between 0 and "
^ Int32.to_string Int32.max_int
^ ")" )
in
match n with
| Micheline.Int (_, n') -> (
try
let n'' = Z.to_int n' in
if
Compare.Int.(0 <= n'')
&& Compare.Int.(n'' <= Int32.to_int Int32.max_int)
then ok n''
else error @@ error' ()
with _ -> error @@ error' () )
| _ ->
error @@ error' ()
and parse_instr :
type bef.
?type_logger:type_logger ->
tc_context ->
context ->
legacy:bool ->
Script.node ->
bef stack_ty ->
(bef judgement * context) tzresult Lwt.t =
fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty ->
let _check_item check loc name n m =
trace_eval (fun () ->
serialize_stack_for_error ctxt stack_ty
>>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty))
@@ trace (Bad_stack_item n) @@ Lwt.return check
in
let check_item_ty (type a b) ctxt (exp : a ty) (got : b ty) loc name n m :
((a, b) eq * a ty * context) tzresult Lwt.t =
trace_eval (fun () ->
serialize_stack_for_error ctxt stack_ty
>>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty))
@@ trace (Bad_stack_item n)
@@ Lwt.return
( ty_eq ctxt exp got
>>? fun (Eq, ctxt) ->
merge_types ~legacy ctxt loc exp got
>>? fun (ty, ctxt) -> ok ((Eq : (a, b) eq), (ty : a ty), ctxt) )
in
let check_item_comparable_ty (type a b) (exp : a comparable_ty)
(got : b comparable_ty) loc name n m :
((a, b) eq * a comparable_ty) tzresult Lwt.t =
trace_eval (fun () ->
serialize_stack_for_error ctxt stack_ty
>>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty))
@@ trace (Bad_stack_item n)
@@ Lwt.return
( comparable_ty_eq ctxt exp got
>>? fun Eq ->
merge_comparable_types ~legacy exp got
>>? fun ty -> ok ((Eq : (a, b) eq), (ty : a comparable_ty)) )
in
let log_stack ctxt loc stack_ty aft =
match (type_logger, script_instr) with
| (None, _) | (Some _, (Seq (-1, _) | Int _ | String _ | Bytes _)) ->
return_unit
| (Some log, (Prim _ | Seq _)) ->
(* Unparsing for logging done in an unlimited context as this
is used only by the client and not the protocol *)
let ctxt = Gas.set_unlimited ctxt in
unparse_stack ctxt stack_ty
>>=? fun (stack_ty, _) ->
unparse_stack ctxt aft
>>=? fun (aft, _) -> log loc stack_ty aft ; return_unit
in
let outer_return = return in
let return :
type bef.
context -> bef judgement -> (bef judgement * context) tzresult Lwt.t =
fun ctxt judgement ->
match judgement with
| Typed {instr; loc; aft; _} ->
let maximum_type_size = Constants.michelson_maximum_type_size ctxt in
let type_size =
type_size_of_stack_head
aft
~up_to:(number_of_generated_growing_types instr)
in
if Compare.Int.(type_size > maximum_type_size) then
fail (Type_too_large (loc, type_size, maximum_type_size))
else return (judgement, ctxt)
| Failed _ ->
return (judgement, ctxt)
in
let typed ctxt loc instr aft =
log_stack ctxt loc stack_ty aft
>>=? fun () ->
Lwt.return @@ Gas.consume ctxt (Typecheck_costs.instr instr)
>>=? fun ctxt -> return ctxt (Typed {loc; instr; bef = stack_ty; aft})
in
Lwt.return @@ Gas.consume ctxt Typecheck_costs.cycle
>>=? fun ctxt ->
match (script_instr, stack_ty) with
(* stack ops *)
| (Prim (loc, I_DROP, [], annot), Item_t (_, rest, _)) ->
( fail_unexpected_annot loc annot >>=? fun () -> typed ctxt loc Drop rest
: (bef judgement * context) tzresult Lwt.t )
| (Prim (loc, I_DROP, [n], result_annot), whole_stack) ->
Lwt.return (parse_int32 n)
>>=? fun whole_n ->
let rec make_proof_argument :
type tstk.
int -> tstk stack_ty -> tstk dropn_proof_argument tzresult Lwt.t =
fun n stk ->
match (Compare.Int.(n = 0), stk) with
| (true, rest) ->
outer_return @@ Dropn_proof_argument (Rest, rest, rest)
| (false, Item_t (v, rest, annot)) ->
make_proof_argument (n - 1) rest
>>=? fun (Dropn_proof_argument (n', stack_after_drops, aft')) ->
outer_return
@@ Dropn_proof_argument
(Prefix n', stack_after_drops, Item_t (v, aft', annot))
| (_, _) ->
serialize_stack_for_error ctxt whole_stack
>>=? fun (whole_stack, _ctxt) ->
fail (Bad_stack (loc, I_DROP, whole_n, whole_stack))
in
fail_unexpected_annot loc result_annot
>>=? fun () ->
make_proof_argument whole_n whole_stack
>>=? fun (Dropn_proof_argument (n', stack_after_drops, _aft)) ->
typed ctxt loc (Dropn (whole_n, n')) stack_after_drops
| (Prim (loc, I_DROP, (_ :: _ :: _ as l), _), _) ->
(* Technically, the arities 0 and 1 are allowed but the error only mentions 1.
However, DROP is equivalent to DROP 1 so hinting at an arity of 1 makes sense. *)
fail (Invalid_arity (loc, I_DROP, 1, List.length l))
| (Prim (loc, I_DUP, [], annot), Item_t (v, rest, stack_annot)) ->
parse_var_annot loc annot ~default:stack_annot
>>=? fun annot ->
typed ctxt loc Dup (Item_t (v, Item_t (v, rest, stack_annot), annot))
| (Prim (loc, I_DIG, [n], result_annot), stack) ->
let rec make_proof_argument :
type tstk.
int -> tstk stack_ty -> tstk dig_proof_argument tzresult Lwt.t =
fun n stk ->
match (Compare.Int.(n = 0), stk) with
| (true, Item_t (v, rest, annot)) ->
outer_return @@ Dig_proof_argument (Rest, (v, annot), rest)
| (false, Item_t (v, rest, annot)) ->
make_proof_argument (n - 1) rest
>>=? fun (Dig_proof_argument (n', (x, xv), aft')) ->
outer_return
@@ Dig_proof_argument (Prefix n', (x, xv), Item_t (v, aft', annot))
| (_, _) ->
serialize_stack_for_error ctxt stack
>>=? fun (whole_stack, _ctxt) ->
fail (Bad_stack (loc, I_DIG, 1, whole_stack))
in
Lwt.return (parse_int32 n)
>>=? fun n ->
fail_unexpected_annot loc result_annot
>>=? fun () ->
make_proof_argument n stack
>>=? fun (Dig_proof_argument (n', (x, stack_annot), aft)) ->
typed ctxt loc (Dig (n, n')) (Item_t (x, aft, stack_annot))
| (Prim (loc, I_DIG, (([] | _ :: _ :: _) as l), _), _) ->
fail (Invalid_arity (loc, I_DIG, 1, List.length l))
| (Prim (loc, I_DUG, [n], result_annot), Item_t (x, whole_stack, stack_annot))
->
Lwt.return (parse_int32 n)
>>=? fun whole_n ->
let rec make_proof_argument :
type tstk x.
int ->
x ty ->
var_annot option ->
tstk stack_ty ->
(tstk, x) dug_proof_argument tzresult Lwt.t =
fun n x stack_annot stk ->
match (Compare.Int.(n = 0), stk) with
| (true, rest) ->
outer_return
@@ Dug_proof_argument (Rest, (), Item_t (x, rest, stack_annot))
| (false, Item_t (v, rest, annot)) ->
make_proof_argument (n - 1) x stack_annot rest
>>=? fun (Dug_proof_argument (n', (), aft')) ->
outer_return
@@ Dug_proof_argument (Prefix n', (), Item_t (v, aft', annot))
| (_, _) ->
serialize_stack_for_error ctxt whole_stack
>>=? fun (whole_stack, _ctxt) ->
fail (Bad_stack (loc, I_DUG, whole_n, whole_stack))
in
fail_unexpected_annot loc result_annot
>>=? fun () ->
make_proof_argument whole_n x stack_annot whole_stack
>>=? fun (Dug_proof_argument (n', (), aft)) ->
typed ctxt loc (Dug (whole_n, n')) aft
| (Prim (loc, I_DUG, [_], result_annot), (Empty_t as stack)) ->
fail_unexpected_annot loc result_annot
>>=? fun () ->
serialize_stack_for_error ctxt stack
>>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, I_DUG, 1, stack))
| (Prim (loc, I_DUG, (([] | _ :: _ :: _) as l), _), _) ->
fail (Invalid_arity (loc, I_DUG, 1, List.length l))
| ( Prim (loc, I_SWAP, [], annot),
Item_t (v, Item_t (w, rest, stack_annot), cur_top_annot) ) ->
fail_unexpected_annot loc annot
>>=? fun () ->
typed
ctxt
loc
Swap
(Item_t (w, Item_t (v, rest, cur_top_annot), stack_annot))
| (Prim (loc, I_PUSH, [t; d], annot), stack) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ parse_packable_ty ctxt ~legacy t
>>=? fun (Ex_ty t, ctxt) ->
parse_data ?type_logger ctxt ~legacy t d
>>=? fun (v, ctxt) -> typed ctxt loc (Const v) (Item_t (t, stack, annot))
| (Prim (loc, I_UNIT, [], annot), stack) ->
parse_var_type_annot loc annot
>>=? fun (annot, ty_name) ->
typed ctxt loc (Const ()) (Item_t (Unit_t ty_name, stack, annot))
(* options *)
| (Prim (loc, I_SOME, [], annot), Item_t (t, rest, _)) ->
parse_var_type_annot loc annot
>>=? fun (annot, ty_name) ->
typed
ctxt
loc
Cons_some
(Item_t (Option_t (t, ty_name, has_big_map t), rest, annot))
| (Prim (loc, I_NONE, [t], annot), stack) ->
Lwt.return @@ parse_any_ty ctxt ~legacy t
>>=? fun (Ex_ty t, ctxt) ->
parse_var_type_annot loc annot
>>=? fun (annot, ty_name) ->
typed
ctxt
loc
(Cons_none t)
(Item_t (Option_t (t, ty_name, has_big_map t), stack, annot))
| ( Prim (loc, I_IF_NONE, [bt; bf], annot),
(Item_t (Option_t (t, _, _), rest, option_annot) as bef) ) ->
check_kind [Seq_kind] bt
>>=? fun () ->
check_kind [Seq_kind] bf
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
let annot = gen_access_annot option_annot default_some_annot in
parse_instr ?type_logger tc_context ctxt ~legacy bt rest
>>=? fun (btr, ctxt) ->
parse_instr
?type_logger
tc_context
ctxt
~legacy
bf
(Item_t (t, rest, annot))
>>=? fun (bfr, ctxt) ->
let branch ibt ibf =
{loc; instr = If_none (ibt, ibf); bef; aft = ibt.aft}
in
merge_branches ~legacy ctxt loc btr bfr {branch}
>>=? fun (judgement, ctxt) -> return ctxt judgement
(* pairs *)
| ( Prim (loc, I_PAIR, [], annot),
Item_t (a, Item_t (b, rest, snd_annot), fst_annot) ) ->
parse_constr_annot
loc
annot
~if_special_first:(var_to_field_annot fst_annot)
~if_special_second:(var_to_field_annot snd_annot)
>>=? fun (annot, ty_name, l_field, r_field) ->
typed
ctxt
loc
Cons_pair
(Item_t
( Pair_t
( (a, l_field, fst_annot),
(b, r_field, snd_annot),
ty_name,
has_big_map a || has_big_map b ),
rest,
annot ))
| ( Prim (loc, I_CAR, [], annot),
Item_t
(Pair_t ((a, expected_field_annot, a_annot), _, _, _), rest, pair_annot)
) ->
parse_destr_annot
loc
annot
~pair_annot
~value_annot:a_annot
~field_name:expected_field_annot
~default_accessor:default_car_annot
>>=? fun (annot, field_annot) ->
Lwt.return @@ check_correct_field field_annot expected_field_annot
>>=? fun () -> typed ctxt loc Car (Item_t (a, rest, annot))
| ( Prim (loc, I_CDR, [], annot),
Item_t
(Pair_t (_, (b, expected_field_annot, b_annot), _, _), rest, pair_annot)
) ->
parse_destr_annot
loc
annot
~pair_annot
~value_annot:b_annot
~field_name:expected_field_annot
~default_accessor:default_cdr_annot
>>=? fun (annot, field_annot) ->
Lwt.return @@ check_correct_field field_annot expected_field_annot
>>=? fun () -> typed ctxt loc Cdr (Item_t (b, rest, annot))
(* unions *)
| (Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest, stack_annot)) ->
Lwt.return @@ parse_any_ty ctxt ~legacy tr
>>=? fun (Ex_ty tr, ctxt) ->
parse_constr_annot
loc
annot
~if_special_first:(var_to_field_annot stack_annot)
>>=? fun (annot, tname, l_field, r_field) ->
typed
ctxt
loc
Left
(Item_t
( Union_t
( (tl, l_field),
(tr, r_field),
tname,
has_big_map tl || has_big_map tr ),
rest,
annot ))
| (Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest, stack_annot)) ->
Lwt.return @@ parse_any_ty ctxt ~legacy tl
>>=? fun (Ex_ty tl, ctxt) ->
parse_constr_annot
loc
annot
~if_special_second:(var_to_field_annot stack_annot)
>>=? fun (annot, tname, l_field, r_field) ->
typed
ctxt
loc
Right
(Item_t
( Union_t
( (tl, l_field),
(tr, r_field),
tname,
has_big_map tl || has_big_map tr ),
rest,
annot ))
| ( Prim (loc, I_IF_LEFT, [bt; bf], annot),
( Item_t (Union_t ((tl, l_field), (tr, r_field), _, _), rest, union_annot)
as bef ) ) ->
check_kind [Seq_kind] bt
>>=? fun () ->
check_kind [Seq_kind] bf
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
let left_annot =
gen_access_annot union_annot l_field ~default:default_left_annot
in
let right_annot =
gen_access_annot union_annot r_field ~default:default_right_annot
in
parse_instr
?type_logger
tc_context
ctxt
~legacy
bt
(Item_t (tl, rest, left_annot))
>>=? fun (btr, ctxt) ->
parse_instr
?type_logger
tc_context
ctxt
~legacy
bf
(Item_t (tr, rest, right_annot))
>>=? fun (bfr, ctxt) ->
let branch ibt ibf =
{loc; instr = If_left (ibt, ibf); bef; aft = ibt.aft}
in
merge_branches ~legacy ctxt loc btr bfr {branch}
>>=? fun (judgement, ctxt) -> return ctxt judgement
(* lists *)
| (Prim (loc, I_NIL, [t], annot), stack) ->
Lwt.return @@ parse_any_ty ctxt ~legacy t
>>=? fun (Ex_ty t, ctxt) ->
parse_var_type_annot loc annot
>>=? fun (annot, ty_name) ->
typed
ctxt
loc
Nil
(Item_t (List_t (t, ty_name, has_big_map t), stack, annot))
| ( Prim (loc, I_CONS, [], annot),
Item_t (tv, Item_t (List_t (t, ty_name, has_big_map), rest, _), _) ) ->
check_item_ty ctxt tv t loc I_CONS 1 2
>>=? fun (Eq, t, ctxt) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Cons_list
(Item_t (List_t (t, ty_name, has_big_map), rest, annot))
| ( Prim (loc, I_IF_CONS, [bt; bf], annot),
(Item_t (List_t (t, ty_name, has_big_map), rest, list_annot) as bef) ) ->
check_kind [Seq_kind] bt
>>=? fun () ->
check_kind [Seq_kind] bf
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
let hd_annot = gen_access_annot list_annot default_hd_annot in
let tl_annot = gen_access_annot list_annot default_tl_annot in
parse_instr
?type_logger
tc_context
ctxt
~legacy
bt
(Item_t
( t,
Item_t (List_t (t, ty_name, has_big_map), rest, tl_annot),
hd_annot ))
>>=? fun (btr, ctxt) ->
parse_instr ?type_logger tc_context ctxt ~legacy bf rest
>>=? fun (bfr, ctxt) ->
let branch ibt ibf =
{loc; instr = If_cons (ibt, ibf); bef; aft = ibt.aft}
in
merge_branches ~legacy ctxt loc btr bfr {branch}
>>=? fun (judgement, ctxt) -> return ctxt judgement
| (Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest, _)) ->
parse_var_type_annot loc annot
>>=? fun (annot, tname) ->
typed ctxt loc List_size (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_MAP, [body], annot),
Item_t (List_t (elt, _, _), starting_rest, list_annot) ) -> (
check_kind [Seq_kind] body
>>=? fun () ->
parse_var_type_annot loc annot
>>=? fun (ret_annot, list_ty_name) ->
let elt_annot = gen_access_annot list_annot default_elt_annot in
parse_instr
?type_logger
tc_context
ctxt
~legacy
body
(Item_t (elt, starting_rest, elt_annot))
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ({aft = Item_t (ret, rest, _); _} as ibody) ->
let invalid_map_body () =
serialize_stack_for_error ctxt ibody.aft
>>|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft)
in
trace_eval
invalid_map_body
( Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest
>>=? fun (rest, ctxt) ->
typed
ctxt
loc
(List_map ibody)
(Item_t
(List_t (ret, list_ty_name, has_big_map ret), rest, ret_annot))
)
| Typed {aft; _} ->
serialize_stack_for_error ctxt aft
>>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft))
| Failed _ ->
fail (Invalid_map_block_fail loc) )
| ( Prim (loc, I_ITER, [body], annot),
Item_t (List_t (elt, _, _), rest, list_annot) ) -> (
check_kind [Seq_kind] body
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
let elt_annot = gen_access_annot list_annot default_elt_annot in
parse_instr
?type_logger
tc_context
ctxt
~legacy
body
(Item_t (elt, rest, elt_annot))
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ({aft; _} as ibody) ->
let invalid_iter_body () =
serialize_stack_for_error ctxt ibody.aft
>>=? fun (aft, ctxt) ->
serialize_stack_for_error ctxt rest
>>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft)
in
trace_eval
invalid_iter_body
( Lwt.return @@ stack_ty_eq ctxt 1 aft rest
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest
>>=? fun (rest, ctxt) -> typed ctxt loc (List_iter ibody) rest )
| Failed {descr} ->
typed ctxt loc (List_iter (descr rest)) rest )
(* sets *)
| (Prim (loc, I_EMPTY_SET, [t], annot), rest) ->
Lwt.return @@ parse_comparable_ty ctxt t
>>=? fun (Ex_comparable_ty t, ctxt) ->
parse_var_type_annot loc annot
>>=? fun (annot, tname) ->
typed ctxt loc (Empty_set t) (Item_t (Set_t (t, tname), rest, annot))
| ( Prim (loc, I_ITER, [body], annot),
Item_t (Set_t (comp_elt, _), rest, set_annot) ) -> (
check_kind [Seq_kind] body
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
let elt_annot = gen_access_annot set_annot default_elt_annot in
let elt = ty_of_comparable_ty comp_elt in
parse_instr
?type_logger
tc_context
ctxt
~legacy
body
(Item_t (elt, rest, elt_annot))
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ({aft; _} as ibody) ->
let invalid_iter_body () =
serialize_stack_for_error ctxt ibody.aft
>>=? fun (aft, ctxt) ->
serialize_stack_for_error ctxt rest
>>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft)
in
trace_eval
invalid_iter_body
( Lwt.return @@ stack_ty_eq ctxt 1 aft rest
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest
>>=? fun (rest, ctxt) -> typed ctxt loc (Set_iter ibody) rest )
| Failed {descr} ->
typed ctxt loc (Set_iter (descr rest)) rest )
| ( Prim (loc, I_MEM, [], annot),
Item_t (v, Item_t (Set_t (elt, _), rest, _), _) ) ->
let elt = ty_of_comparable_ty elt in
parse_var_type_annot loc annot
>>=? fun (annot, tname) ->
check_item_ty ctxt elt v loc I_MEM 1 2
>>=? fun (Eq, _, ctxt) ->
typed ctxt loc Set_mem (Item_t (Bool_t tname, rest, annot))
| ( Prim (loc, I_UPDATE, [], annot),
Item_t
( v,
Item_t (Bool_t _, Item_t (Set_t (elt, tname), rest, set_annot), _),
_ ) ) -> (
match comparable_ty_of_ty v with
| None ->
unparse_ty ctxt v
>>=? fun (v, _ctxt) ->
fail (Comparable_type_expected (loc, Micheline.strip_locations v))
| Some v ->
parse_var_annot loc annot ~default:set_annot
>>=? fun annot ->
check_item_comparable_ty elt v loc I_UPDATE 1 3
>>=? fun (Eq, elt) ->
typed ctxt loc Set_update (Item_t (Set_t (elt, tname), rest, annot)) )
| (Prim (loc, I_SIZE, [], annot), Item_t (Set_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Set_size (Item_t (Nat_t None, rest, annot))
(* maps *)
| (Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack) ->
Lwt.return @@ parse_comparable_ty ctxt tk
>>=? fun (Ex_comparable_ty tk, ctxt) ->
Lwt.return @@ parse_any_ty ctxt ~legacy tv
>>=? fun (Ex_ty tv, ctxt) ->
parse_var_type_annot loc annot
>>=? fun (annot, ty_name) ->
typed
ctxt
loc
(Empty_map (tk, tv))
(Item_t (Map_t (tk, tv, ty_name, has_big_map tv), stack, annot))
| ( Prim (loc, I_MAP, [body], annot),
Item_t (Map_t (ck, elt, _, _), starting_rest, _map_annot) ) -> (
let k = ty_of_comparable_ty ck in
check_kind [Seq_kind] body
>>=? fun () ->
parse_var_type_annot loc annot
>>=? fun (ret_annot, ty_name) ->
let k_name = field_to_var_annot default_key_annot in
let e_name = field_to_var_annot default_elt_annot in
parse_instr
?type_logger
tc_context
ctxt
~legacy
body
(Item_t
( Pair_t
((k, None, k_name), (elt, None, e_name), None, has_big_map elt),
starting_rest,
None ))
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ({aft = Item_t (ret, rest, _); _} as ibody) ->
let invalid_map_body () =
serialize_stack_for_error ctxt ibody.aft
>>|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft)
in
trace_eval
invalid_map_body
( Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest
>>=? fun (rest, ctxt) ->
typed
ctxt
loc
(Map_map ibody)
(Item_t
(Map_t (ck, ret, ty_name, has_big_map ret), rest, ret_annot))
)
| Typed {aft; _} ->
serialize_stack_for_error ctxt aft
>>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft))
| Failed _ ->
fail (Invalid_map_block_fail loc) )
| ( Prim (loc, I_ITER, [body], annot),
Item_t (Map_t (comp_elt, element_ty, _, _), rest, _map_annot) ) -> (
check_kind [Seq_kind] body
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
let k_name = field_to_var_annot default_key_annot in
let e_name = field_to_var_annot default_elt_annot in
let key = ty_of_comparable_ty comp_elt in
parse_instr
?type_logger
tc_context
ctxt
~legacy
body
(Item_t
( Pair_t
( (key, None, k_name),
(element_ty, None, e_name),
None,
has_big_map element_ty ),
rest,
None ))
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ({aft; _} as ibody) ->
let invalid_iter_body () =
serialize_stack_for_error ctxt ibody.aft
>>=? fun (aft, ctxt) ->
serialize_stack_for_error ctxt rest
>>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft)
in
trace_eval
invalid_iter_body
( Lwt.return @@ stack_ty_eq ctxt 1 aft rest
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest
>>=? fun (rest, ctxt) -> typed ctxt loc (Map_iter ibody) rest )
| Failed {descr} ->
typed ctxt loc (Map_iter (descr rest)) rest )
| ( Prim (loc, I_MEM, [], annot),
Item_t (vk, Item_t (Map_t (ck, _, _, _), rest, _), _) ) ->
let k = ty_of_comparable_ty ck in
check_item_ty ctxt vk k loc I_MEM 1 2
>>=? fun (Eq, _, ctxt) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Map_mem (Item_t (Bool_t None, rest, annot))
| ( Prim (loc, I_GET, [], annot),
Item_t (vk, Item_t (Map_t (ck, elt, _, has_big_map), rest, _), _) ) ->
let k = ty_of_comparable_ty ck in
check_item_ty ctxt vk k loc I_GET 1 2
>>=? fun (Eq, _, ctxt) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Map_get
(Item_t (Option_t (elt, None, has_big_map), rest, annot))
| ( Prim (loc, I_UPDATE, [], annot),
Item_t
( vk,
Item_t
( Option_t (vv, _, _),
Item_t (Map_t (ck, v, map_name, has_big_map), rest, map_annot),
_ ),
_ ) ) ->
let k = ty_of_comparable_ty ck in
check_item_ty ctxt vk k loc I_UPDATE 1 3
>>=? fun (Eq, _, ctxt) ->
check_item_ty ctxt vv v loc I_UPDATE 2 3
>>=? fun (Eq, v, ctxt) ->
parse_var_annot loc annot ~default:map_annot
>>=? fun annot ->
typed
ctxt
loc
Map_update
(Item_t (Map_t (ck, v, map_name, has_big_map), rest, annot))
| (Prim (loc, I_SIZE, [], annot), Item_t (Map_t (_, _, _, _), rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Map_size (Item_t (Nat_t None, rest, annot))
(* big_map *)
| (Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack) ->
Lwt.return @@ parse_comparable_ty ctxt tk
>>=? fun (Ex_comparable_ty tk, ctxt) ->
Lwt.return @@ parse_packable_ty ctxt ~legacy tv
>>=? fun (Ex_ty tv, ctxt) ->
parse_var_type_annot loc annot
>>=? fun (annot, ty_name) ->
typed
ctxt
loc
(Empty_big_map (tk, tv))
(Item_t (Big_map_t (tk, tv, ty_name), stack, annot))
| ( Prim (loc, I_MEM, [], annot),
Item_t (set_key, Item_t (Big_map_t (map_key, _, _), rest, _), _) ) ->
let k = ty_of_comparable_ty map_key in
check_item_ty ctxt set_key k loc I_MEM 1 2
>>=? fun (Eq, _, ctxt) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Big_map_mem (Item_t (Bool_t None, rest, annot))
| ( Prim (loc, I_GET, [], annot),
Item_t (vk, Item_t (Big_map_t (ck, elt, _), rest, _), _) ) ->
let k = ty_of_comparable_ty ck in
check_item_ty ctxt vk k loc I_GET 1 2
>>=? fun (Eq, _, ctxt) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Big_map_get
(Item_t (Option_t (elt, None, has_big_map elt), rest, annot))
| ( Prim (loc, I_UPDATE, [], annot),
Item_t
( set_key,
Item_t
( Option_t (set_value, _, _),
Item_t (Big_map_t (map_key, map_value, map_name), rest, map_annot),
_ ),
_ ) ) ->
let k = ty_of_comparable_ty map_key in
check_item_ty ctxt set_key k loc I_UPDATE 1 3
>>=? fun (Eq, _, ctxt) ->
check_item_ty ctxt set_value map_value loc I_UPDATE 2 3
>>=? fun (Eq, map_value, ctxt) ->
parse_var_annot loc annot ~default:map_annot
>>=? fun annot ->
typed
ctxt
loc
Big_map_update
(Item_t (Big_map_t (map_key, map_value, map_name), rest, annot))
(* control *)
| (Seq (loc, []), stack) ->
typed ctxt loc Nop stack
| (Seq (loc, [single]), stack) -> (
parse_instr ?type_logger tc_context ctxt ~legacy single stack
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ({aft; _} as instr) ->
let nop = {bef = aft; loc; aft; instr = Nop} in
typed ctxt loc (Seq (instr, nop)) aft
| Failed {descr; _} ->
let descr aft =
let nop = {bef = aft; loc; aft; instr = Nop} in
let descr = descr aft in
{descr with instr = Seq (descr, nop)}
in
return ctxt (Failed {descr}) )
| (Seq (loc, hd :: tl), stack) -> (
parse_instr ?type_logger tc_context ctxt ~legacy hd stack
>>=? fun (judgement, ctxt) ->
match judgement with
| Failed _ ->
fail (Fail_not_in_tail_position (Micheline.location hd))
| Typed ({aft = middle; _} as ihd) -> (
parse_instr
?type_logger
tc_context
ctxt
~legacy
(Seq (-1, tl))
middle
>>=? fun (judgement, ctxt) ->
match judgement with
| Failed {descr} ->
let descr ret =
{loc; instr = Seq (ihd, descr ret); bef = stack; aft = ret}
in
return ctxt (Failed {descr})
| Typed itl ->
typed ctxt loc (Seq (ihd, itl)) itl.aft ) )
| (Prim (loc, I_IF, [bt; bf], annot), (Item_t (Bool_t _, rest, _) as bef)) ->
check_kind [Seq_kind] bt
>>=? fun () ->
check_kind [Seq_kind] bf
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
parse_instr ?type_logger tc_context ctxt ~legacy bt rest
>>=? fun (btr, ctxt) ->
parse_instr ?type_logger tc_context ctxt ~legacy bf rest
>>=? fun (bfr, ctxt) ->
let branch ibt ibf = {loc; instr = If (ibt, ibf); bef; aft = ibt.aft} in
merge_branches ~legacy ctxt loc btr bfr {branch}
>>=? fun (judgement, ctxt) -> return ctxt judgement
| ( Prim (loc, I_LOOP, [body], annot),
(Item_t (Bool_t _, rest, _stack_annot) as stack) ) -> (
check_kind [Seq_kind] body
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
parse_instr ?type_logger tc_context ctxt ~legacy body rest
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ibody ->
let unmatched_branches () =
serialize_stack_for_error ctxt ibody.aft
>>=? fun (aft, ctxt) ->
serialize_stack_for_error ctxt stack
>>|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack)
in
trace_eval
unmatched_branches
( Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack
>>=? fun (_stack, ctxt) -> typed ctxt loc (Loop ibody) rest )
| Failed {descr} ->
let ibody = descr stack in
typed ctxt loc (Loop ibody) rest )
| ( Prim (loc, I_LOOP_LEFT, [body], annot),
( Item_t (Union_t ((tl, l_field), (tr, _), _, _), rest, union_annot) as
stack ) ) -> (
check_kind [Seq_kind] body
>>=? fun () ->
parse_var_annot loc annot
>>=? fun annot ->
let l_annot =
gen_access_annot union_annot l_field ~default:default_left_annot
in
parse_instr
?type_logger
tc_context
ctxt
~legacy
body
(Item_t (tl, rest, l_annot))
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ibody ->
let unmatched_branches () =
serialize_stack_for_error ctxt ibody.aft
>>=? fun (aft, ctxt) ->
serialize_stack_for_error ctxt stack
>>|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack)
in
trace_eval
unmatched_branches
( Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack
>>=? fun (_stack, ctxt) ->
typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)) )
| Failed {descr} ->
let ibody = descr stack in
typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)) )
| (Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack) ->
Lwt.return @@ parse_any_ty ctxt ~legacy arg
>>=? fun (Ex_ty arg, ctxt) ->
Lwt.return @@ parse_any_ty ctxt ~legacy ret
>>=? fun (Ex_ty ret, ctxt) ->
check_kind [Seq_kind] code
>>=? fun () ->
parse_var_annot loc annot
>>=? fun annot ->
parse_returning
Lambda
?type_logger
ctxt
~legacy
(arg, default_arg_annot)
ret
code
>>=? fun (lambda, ctxt) ->
typed
ctxt
loc
(Lambda lambda)
(Item_t (Lambda_t (arg, ret, None), stack, annot))
| ( Prim (loc, I_EXEC, [], annot),
Item_t (arg, Item_t (Lambda_t (param, ret, _), rest, _), _) ) ->
check_item_ty ctxt arg param loc I_EXEC 1 2
>>=? fun (Eq, _, ctxt) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Exec (Item_t (ret, rest, annot))
| ( Prim (loc, I_APPLY, [], annot),
Item_t
( capture,
Item_t
( Lambda_t
( Pair_t ((capture_ty, _, _), (arg_ty, _, _), lam_annot, _),
ret,
_ ),
rest,
_ ),
_ ) ) ->
Lwt.return @@ check_packable ~legacy:false loc capture_ty
>>=? fun () ->
check_item_ty ctxt capture capture_ty loc I_APPLY 1 2
>>=? fun (Eq, capture_ty, ctxt) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
(Apply capture_ty)
(Item_t (Lambda_t (arg_ty, ret, lam_annot), rest, annot))
| (Prim (loc, I_DIP, [code], annot), Item_t (v, rest, stack_annot)) -> (
fail_unexpected_annot loc annot
>>=? fun () ->
check_kind [Seq_kind] code
>>=? fun () ->
parse_instr
?type_logger
(add_dip v stack_annot tc_context)
ctxt
~legacy
code
rest
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed descr ->
typed ctxt loc (Dip descr) (Item_t (v, descr.aft, stack_annot))
| Failed _ ->
fail (Fail_not_in_tail_position loc) )
| (Prim (loc, I_DIP, [n; code], result_annot), stack)
when match parse_int32 n with Ok _ -> true | Error _ -> false ->
let rec make_proof_argument :
type tstk.
int
(* -> (fbef stack_ty -> (fbef judgement * context) tzresult Lwt.t) *) ->
tc_context ->
tstk stack_ty ->
tstk dipn_proof_argument tzresult Lwt.t =
fun n inner_tc_context stk ->
match (Compare.Int.(n = 0), stk) with
| (true, rest) -> (
parse_instr ?type_logger inner_tc_context ctxt ~legacy code rest
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed descr ->
outer_return
@@ Dipn_proof_argument (Rest, (ctxt, descr), descr.aft)
| Failed _ ->
fail (Fail_not_in_tail_position loc) )
| (false, Item_t (v, rest, annot)) ->
make_proof_argument (n - 1) (add_dip v annot tc_context) rest
>>=? fun (Dipn_proof_argument (n', descr, aft')) ->
outer_return
@@ Dipn_proof_argument (Prefix n', descr, Item_t (v, aft', annot))
| (_, _) ->
serialize_stack_for_error ctxt stack
>>=? fun (whole_stack, _ctxt) ->
fail (Bad_stack (loc, I_DIP, 1, whole_stack))
in
Lwt.return (parse_int32 n)
>>=? fun n ->
fail_unexpected_annot loc result_annot
>>=? fun () ->
make_proof_argument n tc_context stack
>>=? fun (Dipn_proof_argument (n', (new_ctxt, descr), aft)) ->
(* TODO: which context should be used in the next line? new_ctxt or the old ctxt? *)
typed new_ctxt loc (Dipn (n, n', descr)) aft
| (Prim (loc, I_DIP, (([] | _ :: _ :: _ :: _) as l), _), _) ->
(* Technically, the arities 1 and 2 are allowed but the error only mentions 2.
However, DIP {code} is equivalent to DIP 1 {code} so hinting at an arity of 2 makes sense. *)
fail (Invalid_arity (loc, I_DIP, 2, List.length l))
| (Prim (loc, I_FAILWITH, [], annot), Item_t (v, _rest, _)) ->
fail_unexpected_annot loc annot
>>=? fun () ->
let descr aft = {loc; instr = Failwith v; bef = stack_ty; aft} in
log_stack ctxt loc stack_ty Empty_t
>>=? fun () -> return ctxt (Failed {descr})
(* timestamp operations *)
| ( Prim (loc, I_ADD, [], annot),
Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Add_timestamp_to_seconds
(Item_t (Timestamp_t tname, rest, annot))
| ( Prim (loc, I_ADD, [], annot),
Item_t (Int_t _, Item_t (Timestamp_t tname, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Add_seconds_to_timestamp
(Item_t (Timestamp_t tname, rest, annot))
| ( Prim (loc, I_SUB, [], annot),
Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Sub_timestamp_seconds
(Item_t (Timestamp_t tname, rest, annot))
| ( Prim (loc, I_SUB, [], annot),
Item_t (Timestamp_t tn1, Item_t (Timestamp_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Diff_timestamps (Item_t (Int_t tname, rest, annot))
(* string operations *)
| ( Prim (loc, I_CONCAT, [], annot),
Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Concat_string_pair (Item_t (String_t tname, rest, annot))
| ( Prim (loc, I_CONCAT, [], annot),
Item_t (List_t (String_t tname, _, _), rest, list_annot) ) ->
parse_var_annot ~default:list_annot loc annot
>>=? fun annot ->
typed ctxt loc Concat_string (Item_t (String_t tname, rest, annot))
| ( Prim (loc, I_SLICE, [], annot),
Item_t
( Nat_t _,
Item_t (Nat_t _, Item_t (String_t tname, rest, string_annot), _),
_ ) ) ->
parse_var_annot
~default:(gen_access_annot string_annot default_slice_annot)
loc
annot
>>=? fun annot ->
typed
ctxt
loc
Slice_string
(Item_t (Option_t (String_t tname, None, false), rest, annot))
| (Prim (loc, I_SIZE, [], annot), Item_t (String_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc String_size (Item_t (Nat_t None, rest, annot))
(* bytes operations *)
| ( Prim (loc, I_CONCAT, [], annot),
Item_t (Bytes_t tn1, Item_t (Bytes_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Concat_bytes_pair (Item_t (Bytes_t tname, rest, annot))
| ( Prim (loc, I_CONCAT, [], annot),
Item_t (List_t (Bytes_t tname, _, _), rest, list_annot) ) ->
parse_var_annot ~default:list_annot loc annot
>>=? fun annot ->
typed ctxt loc Concat_bytes (Item_t (Bytes_t tname, rest, annot))
| ( Prim (loc, I_SLICE, [], annot),
Item_t
( Nat_t _,
Item_t (Nat_t _, Item_t (Bytes_t tname, rest, bytes_annot), _),
_ ) ) ->
parse_var_annot
~default:(gen_access_annot bytes_annot default_slice_annot)
loc
annot
>>=? fun annot ->
typed
ctxt
loc
Slice_bytes
(Item_t (Option_t (Bytes_t tname, None, false), rest, annot))
| (Prim (loc, I_SIZE, [], annot), Item_t (Bytes_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Bytes_size (Item_t (Nat_t None, rest, annot))
(* currency operations *)
| ( Prim (loc, I_ADD, [], annot),
Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Add_tez (Item_t (Mutez_t tname, rest, annot))
| ( Prim (loc, I_SUB, [], annot),
Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Sub_tez (Item_t (Mutez_t tname, rest, annot))
| ( Prim (loc, I_MUL, [], annot),
Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) ) ->
(* no type name check *)
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Mul_teznat (Item_t (Mutez_t tname, rest, annot))
| ( Prim (loc, I_MUL, [], annot),
Item_t (Nat_t _, Item_t (Mutez_t tname, rest, _), _) ) ->
(* no type name check *)
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Mul_nattez (Item_t (Mutez_t tname, rest, annot))
(* boolean operations *)
| ( Prim (loc, I_OR, [], annot),
Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname -> typed ctxt loc Or (Item_t (Bool_t tname, rest, annot))
| ( Prim (loc, I_AND, [], annot),
Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname -> typed ctxt loc And (Item_t (Bool_t tname, rest, annot))
| ( Prim (loc, I_XOR, [], annot),
Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname -> typed ctxt loc Xor (Item_t (Bool_t tname, rest, annot))
| (Prim (loc, I_NOT, [], annot), Item_t (Bool_t tname, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Not (Item_t (Bool_t tname, rest, annot))
(* integer operations *)
| (Prim (loc, I_ABS, [], annot), Item_t (Int_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Abs_int (Item_t (Nat_t None, rest, annot))
| (Prim (loc, I_ISNAT, [], annot), Item_t (Int_t _, rest, int_annot)) ->
parse_var_annot loc annot ~default:int_annot
>>=? fun annot ->
typed
ctxt
loc
Is_nat
(Item_t (Option_t (Nat_t None, None, false), rest, annot))
| (Prim (loc, I_INT, [], annot), Item_t (Nat_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Int_nat (Item_t (Int_t None, rest, annot))
| (Prim (loc, I_NEG, [], annot), Item_t (Int_t tname, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Neg_int (Item_t (Int_t tname, rest, annot))
| (Prim (loc, I_NEG, [], annot), Item_t (Nat_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Neg_nat (Item_t (Int_t None, rest, annot))
| ( Prim (loc, I_ADD, [], annot),
Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Add_intint (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_ADD, [], annot),
Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Add_intnat (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_ADD, [], annot),
Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Add_natint (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_ADD, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Add_natnat (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_SUB, [], annot),
Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_SUB, [], annot),
Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_SUB, [], annot),
Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_SUB, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun _tname ->
typed ctxt loc Sub_int (Item_t (Int_t None, rest, annot))
| ( Prim (loc, I_MUL, [], annot),
Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Mul_intint (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_MUL, [], annot),
Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Mul_intnat (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_MUL, [], annot),
Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Mul_natint (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_MUL, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Mul_natnat (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_EDIV, [], annot),
Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Ediv_teznat
(Item_t
( Option_t
( Pair_t
( (Mutez_t tname, None, None),
(Mutez_t tname, None, None),
None,
false ),
None,
false ),
rest,
annot ))
| ( Prim (loc, I_EDIV, [], annot),
Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed
ctxt
loc
Ediv_tez
(Item_t
( Option_t
( Pair_t
( (Nat_t None, None, None),
(Mutez_t tname, None, None),
None,
false ),
None,
false ),
rest,
annot ))
| ( Prim (loc, I_EDIV, [], annot),
Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed
ctxt
loc
Ediv_intint
(Item_t
( Option_t
( Pair_t
( (Int_t tname, None, None),
(Nat_t None, None, None),
None,
false ),
None,
false ),
rest,
annot ))
| ( Prim (loc, I_EDIV, [], annot),
Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Ediv_intnat
(Item_t
( Option_t
( Pair_t
( (Int_t tname, None, None),
(Nat_t None, None, None),
None,
false ),
None,
false ),
rest,
annot ))
| ( Prim (loc, I_EDIV, [], annot),
Item_t (Nat_t tname, Item_t (Int_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Ediv_natint
(Item_t
( Option_t
( Pair_t
( (Int_t None, None, None),
(Nat_t tname, None, None),
None,
false ),
None,
false ),
rest,
annot ))
| ( Prim (loc, I_EDIV, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed
ctxt
loc
Ediv_natnat
(Item_t
( Option_t
( Pair_t
( (Nat_t tname, None, None),
(Nat_t tname, None, None),
None,
false ),
None,
false ),
rest,
annot ))
| ( Prim (loc, I_LSL, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Lsl_nat (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_LSR, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Lsr_nat (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_OR, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Or_nat (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_AND, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc And_nat (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_AND, [], annot),
Item_t (Int_t _, Item_t (Nat_t tname, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc And_int_nat (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_XOR, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Xor_nat (Item_t (Nat_t tname, rest, annot))
| (Prim (loc, I_NOT, [], annot), Item_t (Int_t tname, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Not_int (Item_t (Int_t tname, rest, annot))
| (Prim (loc, I_NOT, [], annot), Item_t (Nat_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Not_nat (Item_t (Int_t None, rest, annot))
(* comparison *)
| (Prim (loc, I_COMPARE, [], annot), Item_t (t1, Item_t (t2, rest, _), _))
-> (
parse_var_annot loc annot
>>=? fun annot ->
check_item_ty ctxt t1 t2 loc I_COMPARE 1 2
>>=? fun (Eq, t, ctxt) ->
match comparable_ty_of_ty t with
| None ->
Lwt.return (serialize_ty_for_error ctxt t)
>>=? fun (t, _ctxt) -> fail (Comparable_type_expected (loc, t))
| Some key ->
typed ctxt loc (Compare key) (Item_t (Int_t None, rest, annot)) )
(* comparators *)
| (Prim (loc, I_EQ, [], annot), Item_t (Int_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Eq (Item_t (Bool_t None, rest, annot))
| (Prim (loc, I_NEQ, [], annot), Item_t (Int_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Neq (Item_t (Bool_t None, rest, annot))
| (Prim (loc, I_LT, [], annot), Item_t (Int_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Lt (Item_t (Bool_t None, rest, annot))
| (Prim (loc, I_GT, [], annot), Item_t (Int_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Gt (Item_t (Bool_t None, rest, annot))
| (Prim (loc, I_LE, [], annot), Item_t (Int_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Le (Item_t (Bool_t None, rest, annot))
| (Prim (loc, I_GE, [], annot), Item_t (Int_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Ge (Item_t (Bool_t None, rest, annot))
(* annotations *)
| (Prim (loc, I_CAST, [cast_t], annot), Item_t (t, stack, item_annot)) ->
parse_var_annot loc annot ~default:item_annot
>>=? fun annot ->
Lwt.return @@ parse_any_ty ctxt ~legacy cast_t
>>=? fun (Ex_ty cast_t, ctxt) ->
Lwt.return @@ ty_eq ctxt cast_t t
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_types ~legacy ctxt loc cast_t t
>>=? fun (_, ctxt) -> typed ctxt loc Nop (Item_t (cast_t, stack, annot))
| (Prim (loc, I_RENAME, [], annot), Item_t (t, stack, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
(* can erase annot *)
typed ctxt loc Nop (Item_t (t, stack, annot))
(* packing *)
| (Prim (loc, I_PACK, [], annot), Item_t (t, rest, unpacked_annot)) ->
Lwt.return
(check_packable
~legacy:true
(* allow to pack contracts for hash/signature checks *) loc
t)
>>=? fun () ->
parse_var_annot
loc
annot
~default:(gen_access_annot unpacked_annot default_pack_annot)
>>=? fun annot ->
typed ctxt loc (Pack t) (Item_t (Bytes_t None, rest, annot))
| (Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t _, rest, packed_annot))
->
Lwt.return @@ parse_packable_ty ctxt ~legacy ty
>>=? fun (Ex_ty t, ctxt) ->
parse_var_type_annot loc annot
>>=? fun (annot, ty_name) ->
let annot =
default_annot
annot
~default:(gen_access_annot packed_annot default_unpack_annot)
in
typed
ctxt
loc
(Unpack t)
(Item_t
( Option_t (t, ty_name, false (* cannot unpack big_maps *)),
rest,
annot ))
(* protocol *)
| ( Prim (loc, I_ADDRESS, [], annot),
Item_t (Contract_t _, rest, contract_annot) ) ->
parse_var_annot
loc
annot
~default:(gen_access_annot contract_annot default_addr_annot)
>>=? fun annot ->
typed ctxt loc Address (Item_t (Address_t None, rest, annot))
| ( Prim (loc, I_CONTRACT, [ty], annot),
Item_t (Address_t _, rest, addr_annot) ) ->
Lwt.return @@ parse_parameter_ty ctxt ~legacy ty
>>=? fun (Ex_ty t, ctxt) ->
parse_entrypoint_annot
loc
annot
~default:(gen_access_annot addr_annot default_contract_annot)
>>=? fun (annot, entrypoint) ->
( Lwt.return
@@
match entrypoint with
| None ->
Ok "default"
| Some (`Field_annot "default") ->
error (Unexpected_annotation loc)
| Some (`Field_annot entrypoint) ->
if Compare.Int.(String.length entrypoint > 31) then
error (Entrypoint_name_too_long entrypoint)
else Ok entrypoint )
>>=? fun entrypoint ->
typed
ctxt
loc
(Contract (t, entrypoint))
(Item_t (Option_t (Contract_t (t, None), None, false), rest, annot))
| ( Prim (loc, I_TRANSFER_TOKENS, [], annot),
Item_t (p, Item_t (Mutez_t _, Item_t (Contract_t (cp, _), rest, _), _), _)
) ->
check_item_ty ctxt p cp loc I_TRANSFER_TOKENS 1 4
>>=? fun (Eq, _, ctxt) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Transfer_tokens (Item_t (Operation_t None, rest, annot))
| ( Prim (loc, I_SET_DELEGATE, [], annot),
Item_t (Option_t (Key_hash_t _, _, _), rest, _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Set_delegate (Item_t (Operation_t None, rest, annot))
| ( Prim (loc, I_CREATE_ACCOUNT, [], annot),
Item_t
( Key_hash_t _,
Item_t
( Option_t (Key_hash_t _, _, _),
Item_t (Bool_t _, Item_t (Mutez_t _, rest, _), _),
_ ),
_ ) ) ->
if legacy then
(* For existing contracts, this instruction is still allowed *)
parse_two_var_annot loc annot
>>=? fun (op_annot, addr_annot) ->
typed
ctxt
loc
Create_account
(Item_t
( Operation_t None,
Item_t (Address_t None, rest, addr_annot),
op_annot ))
else
(* For new contracts this instruction is not allowed anymore *)
fail (Deprecated_instruction I_CREATE_ACCOUNT)
| (Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), Item_t (Key_hash_t _, rest, _))
->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Implicit_account
(Item_t (Contract_t (Unit_t None, None), rest, annot))
| ( Prim (loc, I_CREATE_CONTRACT, [(Seq _ as code)], annot),
Item_t
( Key_hash_t _,
Item_t
( Option_t (Key_hash_t _, _, _),
Item_t
( Bool_t _,
Item_t
( Bool_t _,
Item_t (Mutez_t _, Item_t (ginit, rest, _), _),
_ ),
_ ),
_ ),
_ ) ) ->
if legacy then
(* For existing contracts, this instruction is still allowed *)
parse_two_var_annot loc annot
>>=? fun (op_annot, addr_annot) ->
let cannonical_code = fst @@ Micheline.extract_locations code in
Lwt.return @@ parse_toplevel ~legacy cannonical_code
>>=? fun (arg_type, storage_type, code_field, root_name) ->
trace
(Ill_formed_type
(Some "parameter", cannonical_code, location arg_type))
(Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type)
>>=? fun (Ex_ty arg_type, ctxt) ->
( if legacy then Error_monad.return ()
else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
>>=? fun () ->
trace
(Ill_formed_type
(Some "storage", cannonical_code, location storage_type))
(Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type)
>>=? fun (Ex_ty storage_type, ctxt) ->
let arg_annot =
default_annot
(type_to_var_annot (name_of_ty arg_type))
~default:default_param_annot
in
let storage_annot =
default_annot
(type_to_var_annot (name_of_ty storage_type))
~default:default_storage_annot
in
let arg_type_full =
Pair_t
( (arg_type, None, arg_annot),
(storage_type, None, storage_annot),
None,
has_big_map arg_type || has_big_map storage_type )
in
let ret_type_full =
Pair_t
( (List_t (Operation_t None, None, false), None, None),
(storage_type, None, None),
None,
has_big_map storage_type )
in
trace
(Ill_typed_contract (cannonical_code, []))
(parse_returning
(Toplevel
{
storage_type;
param_type = arg_type;
root_name;
legacy_create_contract_literal = true;
})
ctxt
~legacy
?type_logger
(arg_type_full, None)
ret_type_full
code_field)
>>=? fun ( ( Lam
( { bef = Item_t (arg, Empty_t, _);
aft = Item_t (ret, Empty_t, _);
_ },
_ ) as lambda ),
ctxt ) ->
Lwt.return @@ ty_eq ctxt arg arg_type_full
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full
>>=? fun (_, ctxt) ->
Lwt.return @@ ty_eq ctxt ret ret_type_full
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full
>>=? fun (_, ctxt) ->
Lwt.return @@ ty_eq ctxt storage_type ginit
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit
>>=? fun (_, ctxt) ->
typed
ctxt
loc
(Create_contract (storage_type, arg_type, lambda, root_name))
(Item_t
( Operation_t None,
Item_t (Address_t None, rest, addr_annot),
op_annot ))
else
(* For new contracts this instruction is not allowed anymore *)
fail (Deprecated_instruction I_CREATE_CONTRACT)
| ( Prim (loc, I_CREATE_CONTRACT, [(Seq _ as code)], annot),
(* Removed the instruction's arguments manager, spendable and delegatable *)
Item_t
( Option_t (Key_hash_t _, _, _),
Item_t (Mutez_t _, Item_t (ginit, rest, _), _),
_ ) ) ->
parse_two_var_annot loc annot
>>=? fun (op_annot, addr_annot) ->
let cannonical_code = fst @@ Micheline.extract_locations code in
Lwt.return @@ parse_toplevel ~legacy cannonical_code
>>=? fun (arg_type, storage_type, code_field, root_name) ->
trace
(Ill_formed_type (Some "parameter", cannonical_code, location arg_type))
(Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type)
>>=? fun (Ex_ty arg_type, ctxt) ->
( if legacy then Error_monad.return ()
else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
>>=? fun () ->
trace
(Ill_formed_type
(Some "storage", cannonical_code, location storage_type))
(Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type)
>>=? fun (Ex_ty storage_type, ctxt) ->
let arg_annot =
default_annot
(type_to_var_annot (name_of_ty arg_type))
~default:default_param_annot
in
let storage_annot =
default_annot
(type_to_var_annot (name_of_ty storage_type))
~default:default_storage_annot
in
let arg_type_full =
Pair_t
( (arg_type, None, arg_annot),
(storage_type, None, storage_annot),
None,
has_big_map arg_type || has_big_map storage_type )
in
let ret_type_full =
Pair_t
( (List_t (Operation_t None, None, false), None, None),
(storage_type, None, None),
None,
has_big_map storage_type )
in
trace
(Ill_typed_contract (cannonical_code, []))
(parse_returning
(Toplevel
{
storage_type;
param_type = arg_type;
root_name;
legacy_create_contract_literal = false;
})
ctxt
~legacy
?type_logger
(arg_type_full, None)
ret_type_full
code_field)
>>=? fun ( ( Lam
( { bef = Item_t (arg, Empty_t, _);
aft = Item_t (ret, Empty_t, _);
_ },
_ ) as lambda ),
ctxt ) ->
Lwt.return @@ ty_eq ctxt arg arg_type_full
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full
>>=? fun (_, ctxt) ->
Lwt.return @@ ty_eq ctxt ret ret_type_full
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full
>>=? fun (_, ctxt) ->
Lwt.return @@ ty_eq ctxt storage_type ginit
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit
>>=? fun (_, ctxt) ->
typed
ctxt
loc
(Create_contract_2 (storage_type, arg_type, lambda, root_name))
(Item_t
( Operation_t None,
Item_t (Address_t None, rest, addr_annot),
op_annot ))
| (Prim (loc, I_NOW, [], annot), stack) ->
parse_var_annot loc annot ~default:default_now_annot
>>=? fun annot ->
typed ctxt loc Now (Item_t (Timestamp_t None, stack, annot))
| (Prim (loc, I_AMOUNT, [], annot), stack) ->
parse_var_annot loc annot ~default:default_amount_annot
>>=? fun annot ->
typed ctxt loc Amount (Item_t (Mutez_t None, stack, annot))
| (Prim (loc, I_CHAIN_ID, [], annot), stack) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc ChainId (Item_t (Chain_id_t None, stack, annot))
| (Prim (loc, I_BALANCE, [], annot), stack) ->
parse_var_annot loc annot ~default:default_balance_annot
>>=? fun annot ->
typed ctxt loc Balance (Item_t (Mutez_t None, stack, annot))
| (Prim (loc, I_HASH_KEY, [], annot), Item_t (Key_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Hash_key (Item_t (Key_hash_t None, rest, annot))
| ( Prim (loc, I_CHECK_SIGNATURE, [], annot),
Item_t
(Key_t _, Item_t (Signature_t _, Item_t (Bytes_t _, rest, _), _), _) )
->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Check_signature (Item_t (Bool_t None, rest, annot))
| (Prim (loc, I_BLAKE2B, [], annot), Item_t (Bytes_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Blake2b (Item_t (Bytes_t None, rest, annot))
| (Prim (loc, I_SHA256, [], annot), Item_t (Bytes_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Sha256 (Item_t (Bytes_t None, rest, annot))
| (Prim (loc, I_SHA512, [], annot), Item_t (Bytes_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Sha512 (Item_t (Bytes_t None, rest, annot))
| (Prim (loc, I_STEPS_TO_QUOTA, [], annot), stack) ->
if legacy then
(* For existing contracts, this instruction is still allowed *)
parse_var_annot loc annot ~default:default_steps_annot
>>=? fun annot ->
typed ctxt loc Steps_to_quota (Item_t (Nat_t None, stack, annot))
else
(* For new contracts this instruction is not allowed anymore *)
fail (Deprecated_instruction I_STEPS_TO_QUOTA)
| (Prim (loc, I_SOURCE, [], annot), stack) ->
parse_var_annot loc annot ~default:default_source_annot
>>=? fun annot ->
typed ctxt loc Source (Item_t (Address_t None, stack, annot))
| (Prim (loc, I_SENDER, [], annot), stack) ->
parse_var_annot loc annot ~default:default_sender_annot
>>=? fun annot ->
typed ctxt loc Sender (Item_t (Address_t None, stack, annot))
| (Prim (loc, I_SELF, [], annot), stack) ->
parse_entrypoint_annot loc annot ~default:default_self_annot
>>=? fun (annot, entrypoint) ->
let entrypoint =
Option.unopt_map
~f:(fun (`Field_annot annot) -> annot)
~default:"default"
entrypoint
in
let rec get_toplevel_type :
tc_context -> (bef judgement * context) tzresult Lwt.t = function
| Lambda ->
fail (Self_in_lambda loc)
| Dip (_, prev) ->
get_toplevel_type prev
| Toplevel
{param_type; root_name; legacy_create_contract_literal = false} ->
Lwt.return (find_entrypoint param_type ~root_name entrypoint)
>>=? fun (_, Ex_ty param_type) ->
typed
ctxt
loc
(Self (param_type, entrypoint))
(Item_t (Contract_t (param_type, None), stack, annot))
| Toplevel
{param_type; root_name = _; legacy_create_contract_literal = true}
->
typed
ctxt
loc
(Self (param_type, "default"))
(Item_t (Contract_t (param_type, None), stack, annot))
in
get_toplevel_type tc_context
(* Primitive parsing errors *)
| ( Prim
( loc,
( ( I_DUP
| I_SWAP
| I_SOME
| I_UNIT
| I_PAIR
| I_CAR
| I_CDR
| I_CONS
| I_CONCAT
| I_SLICE
| I_MEM
| I_UPDATE
| I_MAP
| I_GET
| I_EXEC
| I_FAILWITH
| I_SIZE
| I_ADD
| I_SUB
| I_MUL
| I_EDIV
| I_OR
| I_AND
| I_XOR
| I_NOT
| I_ABS
| I_NEG
| I_LSL
| I_LSR
| I_COMPARE
| I_EQ
| I_NEQ
| I_LT
| I_GT
| I_LE
| I_GE
| I_TRANSFER_TOKENS
| I_CREATE_ACCOUNT
| I_SET_DELEGATE
| I_NOW
| I_IMPLICIT_ACCOUNT
| I_AMOUNT
| I_BALANCE
| I_CHECK_SIGNATURE
| I_HASH_KEY
| I_SOURCE
| I_SENDER
| I_BLAKE2B
| I_SHA256
| I_SHA512
| I_STEPS_TO_QUOTA
| I_ADDRESS ) as name ),
(_ :: _ as l),
_ ),
_ ) ->
fail (Invalid_arity (loc, name, 0, List.length l))
| ( Prim
( loc,
( ( I_NONE
| I_LEFT
| I_RIGHT
| I_NIL
| I_MAP
| I_ITER
| I_EMPTY_SET
| I_DIP
| I_LOOP
| I_LOOP_LEFT
| I_CONTRACT ) as name ),
(([] | _ :: _ :: _) as l),
_ ),
_ ) ->
fail (Invalid_arity (loc, name, 1, List.length l))
| ( Prim
( loc,
( (I_PUSH | I_IF_NONE | I_IF_LEFT | I_IF_CONS | I_EMPTY_MAP | I_IF)
as name ),
(([] | [_] | _ :: _ :: _ :: _) as l),
_ ),
_ ) ->
fail (Invalid_arity (loc, name, 2, List.length l))
| (Prim (loc, I_LAMBDA, (([] | [_] | _ :: _ :: _ :: _ :: _) as l), _), _) ->
fail (Invalid_arity (loc, I_LAMBDA, 3, List.length l))
(* Stack errors *)
| ( Prim
( loc,
( ( I_ADD
| I_SUB
| I_MUL
| I_EDIV
| I_AND
| I_OR
| I_XOR
| I_LSL
| I_LSR ) as name ),
[],
_ ),
Item_t (ta, Item_t (tb, _, _), _) ) ->
Lwt.return @@ serialize_ty_for_error ctxt ta
>>=? fun (ta, ctxt) ->
Lwt.return @@ serialize_ty_for_error ctxt tb
>>=? fun (tb, _ctxt) -> fail (Undefined_binop (loc, name, ta, tb))
| ( Prim
( loc,
( ( I_NEG
| I_ABS
| I_NOT
| I_CONCAT
| I_SIZE
| I_EQ
| I_NEQ
| I_LT
| I_GT
| I_LE
| I_GE ) as name ),
[],
_ ),
Item_t (t, _, _) ) ->
Lwt.return @@ serialize_ty_for_error ctxt t
>>=? fun (t, _ctxt) -> fail (Undefined_unop (loc, name, t))
| (Prim (loc, ((I_UPDATE | I_SLICE) as name), [], _), stack) ->
serialize_stack_for_error ctxt stack
>>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 3, stack))
| (Prim (loc, I_CREATE_CONTRACT, _, _), stack) ->
serialize_stack_for_error ctxt stack
>>=? fun (stack, _ctxt) ->
fail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack))
| (Prim (loc, I_CREATE_ACCOUNT, [], _), stack) ->
serialize_stack_for_error ctxt stack
>>=? fun (stack, _ctxt) ->
fail (Bad_stack (loc, I_CREATE_ACCOUNT, 4, stack))
| (Prim (loc, I_TRANSFER_TOKENS, [], _), stack) ->
serialize_stack_for_error ctxt stack
>>=? fun (stack, _ctxt) ->
fail (Bad_stack (loc, I_TRANSFER_TOKENS, 4, stack))
| ( Prim
( loc,
( ( I_DROP
| I_DUP
| I_CAR
| I_CDR
| I_SOME
| I_BLAKE2B
| I_SHA256
| I_SHA512
| I_DIP
| I_IF_NONE
| I_LEFT
| I_RIGHT
| I_IF_LEFT
| I_IF
| I_LOOP
| I_IF_CONS
| I_IMPLICIT_ACCOUNT
| I_NEG
| I_ABS
| I_INT
| I_NOT
| I_HASH_KEY
| I_EQ
| I_NEQ
| I_LT
| I_GT
| I_LE
| I_GE ) as name ),
_,
_ ),
stack ) ->
serialize_stack_for_error ctxt stack
>>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 1, stack))
| ( Prim
( loc,
( ( I_SWAP
| I_PAIR
| I_CONS
| I_GET
| I_MEM
| I_EXEC
| I_CHECK_SIGNATURE
| I_ADD
| I_SUB
| I_MUL
| I_EDIV
| I_AND
| I_OR
| I_XOR
| I_LSL
| I_LSR ) as name ),
_,
_ ),
stack ) ->
serialize_stack_for_error ctxt stack
>>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 2, stack))
(* Generic parsing errors *)
| (expr, _) ->
fail
@@ unexpected
expr
[Seq_kind]
Instr_namespace
[ I_DROP;
I_DUP;
I_DIG;
I_DUG;
I_SWAP;
I_SOME;
I_UNIT;
I_PAIR;
I_CAR;
I_CDR;
I_CONS;
I_MEM;
I_UPDATE;
I_MAP;
I_ITER;
I_GET;
I_EXEC;
I_FAILWITH;
I_SIZE;
I_CONCAT;
I_ADD;
I_SUB;
I_MUL;
I_EDIV;
I_OR;
I_AND;
I_XOR;
I_NOT;
I_ABS;
I_INT;
I_NEG;
I_LSL;
I_LSR;
I_COMPARE;
I_EQ;
I_NEQ;
I_LT;
I_GT;
I_LE;
I_GE;
I_TRANSFER_TOKENS;
I_CREATE_ACCOUNT;
I_CREATE_CONTRACT;
I_NOW;
I_AMOUNT;
I_BALANCE;
I_IMPLICIT_ACCOUNT;
I_CHECK_SIGNATURE;
I_BLAKE2B;
I_SHA256;
I_SHA512;
I_HASH_KEY;
I_STEPS_TO_QUOTA;
I_PUSH;
I_NONE;
I_LEFT;
I_RIGHT;
I_NIL;
I_EMPTY_SET;
I_DIP;
I_LOOP;
I_IF_NONE;
I_IF_LEFT;
I_IF_CONS;
I_EMPTY_MAP;
I_IF;
I_SOURCE;
I_SENDER;
I_SELF;
I_LAMBDA ]
and parse_contract :
type arg.
legacy:bool ->
context ->
Script.location ->
arg ty ->
Contract.t ->
entrypoint:string ->
(context * arg typed_contract) tzresult Lwt.t =
fun ~legacy ctxt loc arg contract ~entrypoint ->
Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists
>>=? fun ctxt ->
Contract.exists ctxt contract
>>=? function
| false ->
fail (Invalid_contract (loc, contract))
| true -> (
Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script
>>=? fun ctxt ->
trace (Invalid_contract (loc, contract))
@@ Contract.get_script_code ctxt contract
>>=? fun (ctxt, code) ->
match code with
| None ->
Lwt.return
( ty_eq ctxt arg (Unit_t None)
>>? fun (Eq, ctxt) ->
match entrypoint with
| "default" ->
let contract : arg typed_contract =
(arg, (contract, entrypoint))
in
ok (ctxt, contract)
| entrypoint ->
error (No_such_entrypoint entrypoint) )
| Some code ->
Script.force_decode ctxt code
>>=? fun (code, ctxt) ->
Lwt.return
( parse_toplevel ~legacy:true code
>>? fun (arg_type, _, _, root_name) ->
parse_parameter_ty ctxt ~legacy:true arg_type
>>? fun (Ex_ty targ, ctxt) ->
let return ctxt targ entrypoint =
merge_types ~legacy ctxt loc targ arg
>>? fun (arg, ctxt) ->
let contract : arg typed_contract =
(arg, (contract, entrypoint))
in
ok (ctxt, contract)
in
find_entrypoint_for_type
~full:targ
~expected:arg
~root_name
entrypoint
ctxt
>>? fun (ctxt, entrypoint, targ) ->
merge_types ~legacy ctxt loc targ arg
>>? fun (targ, ctxt) -> return ctxt targ entrypoint ) )
(* Same as the one above, but does not fail when the contact is missing or
if the expected type doesn't match the actual one. In that case None is
returned and some overapproximation of the typechecking gas is consumed.
This can still fail on gas exhaustion. *)
and parse_contract_for_script :
type arg.
legacy:bool ->
context ->
Script.location ->
arg ty ->
Contract.t ->
entrypoint:string ->
(context * arg typed_contract option) tzresult Lwt.t =
fun ~legacy ctxt loc arg contract ~entrypoint ->
Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists
>>=? fun ctxt ->
Contract.exists ctxt contract
>>=? function
| false ->
return (ctxt, None)
| true -> (
Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script
>>=? fun ctxt ->
trace (Invalid_contract (loc, contract))
@@ Contract.get_script_code ctxt contract
>>=? fun (ctxt, code) ->
match code with
(* can only fail because of gas *)
| None -> (
match entrypoint with
| "default" ->
Lwt.return
( match ty_eq ctxt arg (Unit_t None) with
| Ok (Eq, ctxt) ->
let contract : arg typed_contract =
(arg, (contract, entrypoint))
in
ok (ctxt, Some contract)
| Error _ ->
Gas.consume ctxt Typecheck_costs.cycle
>>? fun ctxt -> ok (ctxt, None) )
| _ ->
return (ctxt, None) )
| Some code ->
Script.force_decode ctxt code
>>=? fun (code, ctxt) ->
(* can only fail because of gas *)
Lwt.return
( match parse_toplevel ~legacy:true code with
| Error _ ->
error (Invalid_contract (loc, contract))
| Ok (arg_type, _, _, root_name) -> (
match parse_parameter_ty ctxt ~legacy:true arg_type with
| Error _ ->
error (Invalid_contract (loc, contract))
| Ok (Ex_ty targ, ctxt) -> (
match
find_entrypoint_for_type
~full:targ
~expected:arg
~root_name
entrypoint
ctxt
>>? fun (ctxt, entrypoint, targ) ->
merge_types ~legacy ctxt loc targ arg
>>? fun (targ, ctxt) ->
merge_types ~legacy ctxt loc targ arg
>>? fun (arg, ctxt) ->
let contract : arg typed_contract =
(arg, (contract, entrypoint))
in
ok (ctxt, Some contract)
with
| Ok res ->
ok res
| Error _ ->
(* overapproximation by checking if targ = targ,
can only fail because of gas *)
ty_eq ctxt targ targ
>>? fun (Eq, ctxt) ->
merge_types ~legacy ctxt loc targ targ
>>? fun (_, ctxt) -> ok (ctxt, None) ) ) ) )
and parse_toplevel :
legacy:bool ->
Script.expr ->
(Script.node * Script.node * Script.node * string option) tzresult =
fun ~legacy toplevel ->
record_trace (Ill_typed_contract (toplevel, []))
@@
match root toplevel with
| Int (loc, _) ->
error (Invalid_kind (loc, [Seq_kind], Int_kind))
| String (loc, _) ->
error (Invalid_kind (loc, [Seq_kind], String_kind))
| Bytes (loc, _) ->
error (Invalid_kind (loc, [Seq_kind], Bytes_kind))
| Prim (loc, _, _, _) ->
error (Invalid_kind (loc, [Seq_kind], Prim_kind))
| Seq (_, fields) -> (
let rec find_fields p s c fields =
match fields with
| [] ->
ok (p, s, c)
| Int (loc, _) :: _ ->
error (Invalid_kind (loc, [Prim_kind], Int_kind))
| String (loc, _) :: _ ->
error (Invalid_kind (loc, [Prim_kind], String_kind))
| Bytes (loc, _) :: _ ->
error (Invalid_kind (loc, [Prim_kind], Bytes_kind))
| Seq (loc, _) :: _ ->
error (Invalid_kind (loc, [Prim_kind], Seq_kind))
| Prim (loc, K_parameter, [arg], annot) :: rest -> (
match p with
| None ->
find_fields (Some (arg, loc, annot)) s c rest
| Some _ ->
error (Duplicate_field (loc, K_parameter)) )
| Prim (loc, K_storage, [arg], annot) :: rest -> (
match s with
| None ->
find_fields p (Some (arg, loc, annot)) c rest
| Some _ ->
error (Duplicate_field (loc, K_storage)) )
| Prim (loc, K_code, [arg], annot) :: rest -> (
match c with
| None ->
find_fields p s (Some (arg, loc, annot)) rest
| Some _ ->
error (Duplicate_field (loc, K_code)) )
| Prim (loc, ((K_parameter | K_storage | K_code) as name), args, _)
:: _ ->
error (Invalid_arity (loc, name, 1, List.length args))
| Prim (loc, name, _, _) :: _ ->
let allowed = [K_parameter; K_storage; K_code] in
error (Invalid_primitive (loc, allowed, name))
in
find_fields None None None fields
>>? function
| (None, _, _) ->
error (Missing_field K_parameter)
| (Some _, None, _) ->
error (Missing_field K_storage)
| (Some _, Some _, None) ->
error (Missing_field K_code)
| (Some (p, ploc, pannot), Some (s, sloc, sannot), Some (c, cloc, carrot))
->
let maybe_root_name =
(* root name can be attached to either the parameter
primitive or the toplevel constructor *)
Script_ir_annot.extract_field_annot p
>>? fun (p, root_name) ->
match root_name with
| Some (`Field_annot root_name) ->
ok (p, pannot, Some root_name)
| None -> (
match pannot with
| [single]
when Compare.Int.(String.length single > 0)
&& Compare.Char.(single.[0] = '%') ->
ok
( p,
[],
Some (String.sub single 1 (String.length single - 1)) )
| _ ->
ok (p, pannot, None) )
in
if legacy then
(* legacy semantics ignores spurious annotations *)
let (p, root_name) =
match maybe_root_name with
| Ok (p, _, root_name) ->
(p, root_name)
| Error _ ->
(p, None)
in
ok (p, s, c, root_name)
else
(* only one field annot is allowed to set the root entrypoint name *)
maybe_root_name
>>? fun (p, pannot, root_name) ->
Script_ir_annot.error_unexpected_annot ploc pannot
>>? fun () ->
Script_ir_annot.error_unexpected_annot cloc carrot
>>? fun () ->
Script_ir_annot.error_unexpected_annot sloc sannot
>>? fun () -> ok (p, s, c, root_name) )
let parse_script :
?type_logger:type_logger ->
context ->
legacy:bool ->
Script.t ->
(ex_script * context) tzresult Lwt.t =
fun ?type_logger ctxt ~legacy {code; storage} ->
Script.force_decode ctxt code
>>=? fun (code, ctxt) ->
Script.force_decode ctxt storage
>>=? fun (storage, ctxt) ->
Lwt.return @@ parse_toplevel ~legacy code
>>=? fun (arg_type, storage_type, code_field, root_name) ->
trace
(Ill_formed_type (Some "parameter", code, location arg_type))
(Lwt.return (parse_parameter_ty ctxt ~legacy arg_type))
>>=? fun (Ex_ty arg_type, ctxt) ->
( if legacy then return ()
else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
>>=? fun () ->
trace
(Ill_formed_type (Some "storage", code, location storage_type))
(Lwt.return (parse_storage_ty ctxt ~legacy storage_type))
>>=? fun (Ex_ty storage_type, ctxt) ->
let arg_annot =
default_annot
(type_to_var_annot (name_of_ty arg_type))
~default:default_param_annot
in
let storage_annot =
default_annot
(type_to_var_annot (name_of_ty storage_type))
~default:default_storage_annot
in
let arg_type_full =
Pair_t
( (arg_type, None, arg_annot),
(storage_type, None, storage_annot),
None,
has_big_map arg_type || has_big_map storage_type )
in
let ret_type_full =
Pair_t
( (List_t (Operation_t None, None, false), None, None),
(storage_type, None, None),
None,
has_big_map storage_type )
in
trace_eval
(fun () ->
Lwt.return @@ serialize_ty_for_error ctxt storage_type
>>|? fun (storage_type, _ctxt) ->
Ill_typed_data (None, storage, storage_type))
(parse_data ?type_logger ctxt ~legacy storage_type (root storage))
>>=? fun (storage, ctxt) ->
trace
(Ill_typed_contract (code, []))
(parse_returning
(Toplevel
{
storage_type;
param_type = arg_type;
root_name;
legacy_create_contract_literal = false;
})
ctxt
~legacy
?type_logger
(arg_type_full, None)
ret_type_full
code_field)
>>=? fun (code, ctxt) ->
return (Ex_script {code; arg_type; storage; storage_type; root_name}, ctxt)
let typecheck_code :
context -> Script.expr -> (type_map * context) tzresult Lwt.t =
fun ctxt code ->
let legacy = false in
Lwt.return @@ parse_toplevel ~legacy code
>>=? fun (arg_type, storage_type, code_field, root_name) ->
let type_map = ref [] in
trace
(Ill_formed_type (Some "parameter", code, location arg_type))
(Lwt.return (parse_parameter_ty ctxt ~legacy arg_type))
>>=? fun (Ex_ty arg_type, ctxt) ->
( if legacy then return ()
else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
>>=? fun () ->
trace
(Ill_formed_type (Some "storage", code, location storage_type))
(Lwt.return (parse_storage_ty ctxt ~legacy storage_type))
>>=? fun (Ex_ty storage_type, ctxt) ->
let arg_annot =
default_annot
(type_to_var_annot (name_of_ty arg_type))
~default:default_param_annot
in
let storage_annot =
default_annot
(type_to_var_annot (name_of_ty storage_type))
~default:default_storage_annot
in
let arg_type_full =
Pair_t
( (arg_type, None, arg_annot),
(storage_type, None, storage_annot),
None,
has_big_map arg_type || has_big_map storage_type )
in
let ret_type_full =
Pair_t
( (List_t (Operation_t None, None, false), None, None),
(storage_type, None, None),
None,
has_big_map storage_type )
in
let result =
parse_returning
(Toplevel
{
storage_type;
param_type = arg_type;
root_name;
legacy_create_contract_literal = false;
})
ctxt
~legacy
~type_logger:(fun loc bef aft ->
type_map := (loc, (bef, aft)) :: !type_map)
(arg_type_full, None)
ret_type_full
code_field
in
trace (Ill_typed_contract (code, !type_map)) result
>>=? fun (Lam _, ctxt) -> return (!type_map, ctxt)
let typecheck_data :
?type_logger:type_logger ->
context ->
Script.expr * Script.expr ->
context tzresult Lwt.t =
fun ?type_logger ctxt (data, exp_ty) ->
let legacy = false in
trace
(Ill_formed_type (None, exp_ty, 0))
(Lwt.return @@ parse_packable_ty ctxt ~legacy (root exp_ty))
>>=? fun (Ex_ty exp_ty, ctxt) ->
trace_eval
(fun () ->
Lwt.return @@ serialize_ty_for_error ctxt exp_ty
>>|? fun (exp_ty, _ctxt) -> Ill_typed_data (None, data, exp_ty))
(parse_data ?type_logger ctxt ~legacy exp_ty (root data))
>>=? fun (_, ctxt) -> return ctxt
module Entrypoints_map = Map.Make (String)
let list_entrypoints (type full) (full : full ty) ctxt ~root_name =
let merge path annot (type t) (ty : t ty) reachable
((unreachables, all) as acc) =
match annot with
| None | Some (`Field_annot "") -> (
ok
@@
if reachable then acc
else
match ty with
| Union_t _ ->
acc
| _ ->
(List.rev path :: unreachables, all) )
| Some (`Field_annot name) ->
if Compare.Int.(String.length name > 31) then
ok (List.rev path :: unreachables, all)
else if Entrypoints_map.mem name all then
ok (List.rev path :: unreachables, all)
else
unparse_ty_no_lwt ctxt ty
>>? fun (unparsed_ty, _) ->
ok
( unreachables,
Entrypoints_map.add name (List.rev path, unparsed_ty) all )
in
let rec fold_tree :
type t.
t ty ->
prim list ->
bool ->
prim list list * (prim list * Script.node) Entrypoints_map.t ->
(prim list list * (prim list * Script.node) Entrypoints_map.t) tzresult =
fun t path reachable acc ->
match t with
| Union_t ((tl, al), (tr, ar), _, _) ->
merge (D_Left :: path) al tl reachable acc
>>? fun acc ->
merge (D_Right :: path) ar tr reachable acc
>>? fun acc ->
fold_tree
tl
(D_Left :: path)
(match al with Some _ -> true | None -> reachable)
acc
>>? fun acc ->
fold_tree
tr
(D_Right :: path)
(match ar with Some _ -> true | None -> reachable)
acc
| _ ->
ok acc
in
unparse_ty_no_lwt ctxt full
>>? fun (unparsed_full, _) ->
let (init, reachable) =
match root_name with
| None | Some "" ->
(Entrypoints_map.empty, false)
| Some name ->
(Entrypoints_map.singleton name ([], unparsed_full), true)
in
fold_tree full [] reachable ([], init)
(* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*)
let rec unparse_data :
type a.
context ->
unparsing_mode ->
a ty ->
a ->
(Script.node * context) tzresult Lwt.t =
fun ctxt mode ty a ->
Lwt.return (Gas.consume ctxt Unparse_costs.cycle)
>>=? fun ctxt ->
match (ty, a) with
| (Unit_t _, ()) ->
Lwt.return (Gas.consume ctxt Unparse_costs.unit)
>>=? fun ctxt -> return (Prim (-1, D_Unit, [], []), ctxt)
| (Int_t _, v) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.int v))
>>=? fun ctxt -> return (Int (-1, Script_int.to_zint v), ctxt)
| (Nat_t _, v) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.int v))
>>=? fun ctxt -> return (Int (-1, Script_int.to_zint v), ctxt)
| (String_t _, s) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.string s))
>>=? fun ctxt -> return (String (-1, s), ctxt)
| (Bytes_t _, s) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s))
>>=? fun ctxt -> return (Bytes (-1, s), ctxt)
| (Bool_t _, true) ->
Lwt.return (Gas.consume ctxt Unparse_costs.bool)
>>=? fun ctxt -> return (Prim (-1, D_True, [], []), ctxt)
| (Bool_t _, false) ->
Lwt.return (Gas.consume ctxt Unparse_costs.bool)
>>=? fun ctxt -> return (Prim (-1, D_False, [], []), ctxt)
| (Timestamp_t _, t) -> (
Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t))
>>=? fun ctxt ->
match mode with
| Optimized ->
return (Int (-1, Script_timestamp.to_zint t), ctxt)
| Readable -> (
match Script_timestamp.to_notation t with
| None ->
return (Int (-1, Script_timestamp.to_zint t), ctxt)
| Some s ->
return (String (-1, s), ctxt) ) )
| (Address_t _, (c, entrypoint)) -> (
Lwt.return (Gas.consume ctxt Unparse_costs.contract)
>>=? fun ctxt ->
match mode with
| Optimized ->
let entrypoint =
match entrypoint with "default" -> "" | name -> name
in
let bytes =
Data_encoding.Binary.to_bytes_exn
Data_encoding.(tup2 Contract.encoding Variable.string)
(c, entrypoint)
in
return (Bytes (-1, bytes), ctxt)
| Readable ->
let notation =
match entrypoint with
| "default" ->
Contract.to_b58check c
| entrypoint ->
Contract.to_b58check c ^ "%" ^ entrypoint
in
return (String (-1, notation), ctxt) )
| (Contract_t _, (_, (c, entrypoint))) -> (
Lwt.return (Gas.consume ctxt Unparse_costs.contract)
>>=? fun ctxt ->
match mode with
| Optimized ->
let entrypoint =
match entrypoint with "default" -> "" | name -> name
in
let bytes =
Data_encoding.Binary.to_bytes_exn
Data_encoding.(tup2 Contract.encoding Variable.string)
(c, entrypoint)
in
return (Bytes (-1, bytes), ctxt)
| Readable ->
let notation =
match entrypoint with
| "default" ->
Contract.to_b58check c
| entrypoint ->
Contract.to_b58check c ^ "%" ^ entrypoint
in
return (String (-1, notation), ctxt) )
| (Signature_t _, s) -> (
Lwt.return (Gas.consume ctxt Unparse_costs.signature)
>>=? fun ctxt ->
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in
return (Bytes (-1, bytes), ctxt)
| Readable ->
return (String (-1, Signature.to_b58check s), ctxt) )
| (Mutez_t _, v) ->
Lwt.return (Gas.consume ctxt Unparse_costs.tez)
>>=? fun ctxt -> return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt)
| (Key_t _, k) -> (
Lwt.return (Gas.consume ctxt Unparse_costs.key)
>>=? fun ctxt ->
match mode with
| Optimized ->
let bytes =
Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k
in
return (Bytes (-1, bytes), ctxt)
| Readable ->
return (String (-1, Signature.Public_key.to_b58check k), ctxt) )
| (Key_hash_t _, k) -> (
Lwt.return (Gas.consume ctxt Unparse_costs.key_hash)
>>=? fun ctxt ->
match mode with
| Optimized ->
let bytes =
Data_encoding.Binary.to_bytes_exn
Signature.Public_key_hash.encoding
k
in
return (Bytes (-1, bytes), ctxt)
| Readable ->
return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) )
| (Operation_t _, (op, _big_map_diff)) ->
let bytes =
Data_encoding.Binary.to_bytes_exn
Operation.internal_operation_encoding
op
in
Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes))
>>=? fun ctxt -> return (Bytes (-1, bytes), ctxt)
| (Chain_id_t _, chain_id) ->
let bytes =
Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id
in
Lwt.return (Gas.consume ctxt (Unparse_costs.chain_id bytes))
>>=? fun ctxt -> return (Bytes (-1, bytes), ctxt)
| (Pair_t ((tl, _, _), (tr, _, _), _, _), (l, r)) ->
Lwt.return (Gas.consume ctxt Unparse_costs.pair)
>>=? fun ctxt ->
unparse_data ctxt mode tl l
>>=? fun (l, ctxt) ->
unparse_data ctxt mode tr r
>>=? fun (r, ctxt) -> return (Prim (-1, D_Pair, [l; r], []), ctxt)
| (Union_t ((tl, _), _, _, _), L l) ->
Lwt.return (Gas.consume ctxt Unparse_costs.union)
>>=? fun ctxt ->
unparse_data ctxt mode tl l
>>=? fun (l, ctxt) -> return (Prim (-1, D_Left, [l], []), ctxt)
| (Union_t (_, (tr, _), _, _), R r) ->
Lwt.return (Gas.consume ctxt Unparse_costs.union)
>>=? fun ctxt ->
unparse_data ctxt mode tr r
>>=? fun (r, ctxt) -> return (Prim (-1, D_Right, [r], []), ctxt)
| (Option_t (t, _, _), Some v) ->
Lwt.return (Gas.consume ctxt Unparse_costs.some)
>>=? fun ctxt ->
unparse_data ctxt mode t v
>>=? fun (v, ctxt) -> return (Prim (-1, D_Some, [v], []), ctxt)
| (Option_t _, None) ->
Lwt.return (Gas.consume ctxt Unparse_costs.none)
>>=? fun ctxt -> return (Prim (-1, D_None, [], []), ctxt)
| (List_t (t, _, _), items) ->
fold_left_s
(fun (l, ctxt) element ->
Lwt.return (Gas.consume ctxt Unparse_costs.list_element)
>>=? fun ctxt ->
unparse_data ctxt mode t element
>>=? fun (unparsed, ctxt) -> return (unparsed :: l, ctxt))
([], ctxt)
items
>>=? fun (items, ctxt) ->
return (Micheline.Seq (-1, List.rev items), ctxt)
| (Set_t (t, _), set) ->
let t = ty_of_comparable_ty t in
fold_left_s
(fun (l, ctxt) item ->
Lwt.return (Gas.consume ctxt Unparse_costs.set_element)
>>=? fun ctxt ->
unparse_data ctxt mode t item
>>=? fun (item, ctxt) -> return (item :: l, ctxt))
([], ctxt)
(set_fold (fun e acc -> e :: acc) set [])
>>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt)
| (Map_t (kt, vt, _, _), map) ->
let kt = ty_of_comparable_ty kt in
fold_left_s
(fun (l, ctxt) (k, v) ->
Lwt.return (Gas.consume ctxt Unparse_costs.map_element)
>>=? fun ctxt ->
unparse_data ctxt mode kt k
>>=? fun (key, ctxt) ->
unparse_data ctxt mode vt v
>>=? fun (value, ctxt) ->
return (Prim (-1, D_Elt, [key; value], []) :: l, ctxt))
([], ctxt)
(map_fold (fun k v acc -> (k, v) :: acc) map [])
>>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt)
| (Big_map_t (kt, vt, _), {id = None; diff = (module Diff); _}) ->
(* this branch is to allow roundtrip of big map literals *)
let kt = ty_of_comparable_ty kt in
fold_left_s
(fun (l, ctxt) (k, v) ->
Lwt.return (Gas.consume ctxt Unparse_costs.map_element)
>>=? fun ctxt ->
unparse_data ctxt mode kt k
>>=? fun (key, ctxt) ->
unparse_data ctxt mode vt v
>>=? fun (value, ctxt) ->
return (Prim (-1, D_Elt, [key; value], []) :: l, ctxt))
([], ctxt)
(Diff.OPS.fold
(fun k v acc ->
match v with None -> acc | Some v -> (k, v) :: acc)
(fst Diff.boxed)
[])
>>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt)
| (Big_map_t (_kt, _kv, _), {id = Some id; diff = (module Diff); _}) ->
if Compare.Int.(Diff.OPS.cardinal (fst Diff.boxed) = 0) then
return (Micheline.Int (-1, id), ctxt)
else
(* this can only be the result of an execution and the map
must have been flushed at this point *)
assert false
| (Lambda_t _, Lam (_, original_code)) ->
unparse_code ctxt mode original_code
(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)
and unparse_code ctxt mode =
let legacy = true in
function
| Prim (loc, I_PUSH, [ty; data], annot) ->
Lwt.return (parse_packable_ty ctxt ~legacy ty)
>>=? fun (Ex_ty t, ctxt) ->
parse_data ctxt ~legacy t data
>>=? fun (data, ctxt) ->
unparse_data ctxt mode t data
>>=? fun (data, ctxt) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot))
>>=? fun ctxt -> return (Prim (loc, I_PUSH, [ty; data], annot), ctxt)
| Seq (loc, items) ->
fold_left_s
(fun (l, ctxt) item ->
unparse_code ctxt mode item
>>=? fun (item, ctxt) -> return (item :: l, ctxt))
([], ctxt)
items
>>=? fun (items, ctxt) ->
Lwt.return
(Gas.consume ctxt (Unparse_costs.seq_cost (List.length items)))
>>=? fun ctxt -> return (Micheline.Seq (loc, List.rev items), ctxt)
| Prim (loc, prim, items, annot) ->
fold_left_s
(fun (l, ctxt) item ->
unparse_code ctxt mode item
>>=? fun (item, ctxt) -> return (item :: l, ctxt))
([], ctxt)
items
>>=? fun (items, ctxt) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot))
>>=? fun ctxt -> return (Prim (loc, prim, List.rev items, annot), ctxt)
| (Int _ | String _ | Bytes _) as atom ->
return (atom, ctxt)
(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)
let unparse_script ctxt mode {code; arg_type; storage; storage_type; root_name}
=
let (Lam (_, original_code)) = code in
unparse_code ctxt mode original_code
>>=? fun (code, ctxt) ->
unparse_data ctxt mode storage_type storage
>>=? fun (storage, ctxt) ->
unparse_ty ctxt arg_type
>>=? fun (arg_type, ctxt) ->
unparse_ty ctxt storage_type
>>=? fun (storage_type, ctxt) ->
let arg_type =
add_field_annot
(Option.map ~f:(fun n -> `Field_annot n) root_name)
None
arg_type
in
let open Micheline in
let code =
Seq
( -1,
[ Prim (-1, K_parameter, [arg_type], []);
Prim (-1, K_storage, [storage_type], []);
Prim (-1, K_code, [code], []) ] )
in
Lwt.return
( Gas.consume ctxt (Unparse_costs.seq_cost 3)
>>? fun ctxt ->
Gas.consume ctxt (Unparse_costs.prim_cost 1 [])
>>? fun ctxt ->
Gas.consume ctxt (Unparse_costs.prim_cost 1 [])
>>? fun ctxt -> Gas.consume ctxt (Unparse_costs.prim_cost 1 []) )
>>=? fun ctxt ->
return
( {
code = lazy_expr (strip_locations code);
storage = lazy_expr (strip_locations storage);
},
ctxt )
let pack_data ctxt typ data =
unparse_data ctxt Optimized typ data
>>=? fun (unparsed, ctxt) ->
let bytes =
Data_encoding.Binary.to_bytes_exn
expr_encoding
(Micheline.strip_locations unparsed)
in
Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes)
>>=? fun ctxt ->
let bytes = MBytes.concat "" [MBytes.of_string "\005"; bytes] in
Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes)
>>=? fun ctxt -> return (bytes, ctxt)
let hash_data ctxt typ data =
pack_data ctxt typ data
>>=? fun (bytes, ctxt) ->
Lwt.return
@@ Gas.consume
ctxt
(Michelson_v1_gas.Cost_of.Legacy.hash bytes Script_expr_hash.size)
>>=? fun ctxt -> return (Script_expr_hash.(hash_bytes [bytes]), ctxt)
(* ---------------- Big map -------------------------------------------------*)
let empty_big_map tk tv =
{
id = None;
diff = empty_map tk;
key_type = ty_of_comparable_ty tk;
value_type = tv;
}
let big_map_mem ctxt key {id; diff; key_type; _} =
match (map_get key diff, id) with
| (None, None) ->
return (false, ctxt)
| (None, Some id) ->
hash_data ctxt key_type key
>>=? fun (hash, ctxt) ->
Alpha_context.Big_map.mem ctxt id hash
>>=? fun (ctxt, res) -> return (res, ctxt)
| (Some None, _) ->
return (false, ctxt)
| (Some (Some _), _) ->
return (true, ctxt)
let big_map_get ctxt key {id; diff; key_type; value_type} =
match (map_get key diff, id) with
| (Some x, _) ->
return (x, ctxt)
| (None, None) ->
return (None, ctxt)
| (None, Some id) -> (
hash_data ctxt key_type key
>>=? fun (hash, ctxt) ->
Alpha_context.Big_map.get_opt ctxt id hash
>>=? function
| (ctxt, None) ->
return (None, ctxt)
| (ctxt, Some value) ->
parse_data ctxt ~legacy:true value_type (Micheline.root value)
>>=? fun (x, ctxt) -> return (Some x, ctxt) )
let big_map_update key value ({diff; _} as map) =
{map with diff = map_set key value diff}
module Ids = Set.Make (Compare.Z)
type big_map_ids = Ids.t
let no_big_map_id = Ids.empty
let diff_of_big_map ctxt fresh mode ~ids {id; key_type; value_type; diff} =
Lwt.return
(Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list diff))
>>=? fun ctxt ->
( match id with
| Some id ->
if Ids.mem id ids then
fresh ctxt
>>=? fun (ctxt, duplicate) ->
return (ctxt, [Contract.Copy (id, duplicate)], duplicate)
else
(* The first occurence encountered of a big_map reuses the
ID. This way, the payer is only charged for the diff.
For this to work, this diff has to be put at the end of
the global diff, otherwise the duplicates will use the
updated version as a base. This is true because we add
this diff first in the accumulator of
`extract_big_map_updates`, and this accumulator is not
reversed before being flattened. *)
return (ctxt, [], id)
| None ->
fresh ctxt
>>=? fun (ctxt, id) ->
unparse_ty ctxt key_type
>>=? fun (kt, ctxt) ->
unparse_ty ctxt value_type
>>=? fun (kv, ctxt) ->
return
( ctxt,
[ Contract.Alloc
{
big_map = id;
key_type = Micheline.strip_locations kt;
value_type = Micheline.strip_locations kv;
} ],
id ) )
>>=? fun (ctxt, init, big_map) ->
let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in
fold_left_s
(fun (acc, ctxt) (key, value) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
hash_data ctxt key_type key
>>=? fun (diff_key_hash, ctxt) ->
unparse_data ctxt mode key_type key
>>=? fun (key_node, ctxt) ->
let diff_key = Micheline.strip_locations key_node in
( match value with
| None ->
return (None, ctxt)
| Some x ->
unparse_data ctxt mode value_type x
>>=? fun (node, ctxt) ->
return (Some (Micheline.strip_locations node), ctxt) )
>>=? fun (diff_value, ctxt) ->
let diff_item =
Contract.Update {big_map; diff_key; diff_key_hash; diff_value}
in
return (diff_item :: acc, ctxt))
([], ctxt)
pairs
>>=? fun (diff, ctxt) -> return (init @ diff, big_map, ctxt)
let rec extract_big_map_updates :
type a.
context ->
(context -> (context * Big_map.id) tzresult Lwt.t) ->
unparsing_mode ->
Ids.t ->
Contract.big_map_diff list ->
a ty ->
a ->
(context * a * Ids.t * Contract.big_map_diff list) tzresult Lwt.t =
fun ctxt fresh mode ids acc ty x ->
match (ty, x) with
| (Big_map_t (_, _, _), map) ->
diff_of_big_map ctxt fresh mode ids map
>>=? fun (diff, id, ctxt) ->
let (module Map) = map.diff in
let map = {map with diff = empty_map Map.key_ty; id = Some id} in
return (ctxt, map, Ids.add id ids, diff :: acc)
| (Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr)) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
extract_big_map_updates ctxt fresh mode ids acc tyl xl
>>=? fun (ctxt, xl, ids, acc) ->
extract_big_map_updates ctxt fresh mode ids acc tyr xr
>>=? fun (ctxt, xr, ids, acc) -> return (ctxt, (xl, xr), ids, acc)
| (Union_t ((ty, _), (_, _), _, true), L x) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
extract_big_map_updates ctxt fresh mode ids acc ty x
>>=? fun (ctxt, x, ids, acc) -> return (ctxt, L x, ids, acc)
| (Union_t ((_, _), (ty, _), _, true), R x) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
extract_big_map_updates ctxt fresh mode ids acc ty x
>>=? fun (ctxt, x, ids, acc) -> return (ctxt, R x, ids, acc)
| (Option_t (ty, _, true), Some x) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
extract_big_map_updates ctxt fresh mode ids acc ty x
>>=? fun (ctxt, x, ids, acc) -> return (ctxt, Some x, ids, acc)
| (List_t (ty, _, true), l) ->
fold_left_s
(fun (ctxt, l, ids, acc) x ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
extract_big_map_updates ctxt fresh mode ids acc ty x
>>=? fun (ctxt, x, ids, acc) -> return (ctxt, x :: l, ids, acc))
(ctxt, [], ids, acc)
l
>>=? fun (ctxt, l, ids, acc) -> return (ctxt, List.rev l, ids, acc)
| (Map_t (_, ty, _, true), ((module M) as m)) ->
Lwt.return
(Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list m))
>>=? fun ctxt ->
fold_left_s
(fun (ctxt, m, ids, acc) (k, x) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
extract_big_map_updates ctxt fresh mode ids acc ty x
>>=? fun (ctxt, x, ids, acc) ->
return (ctxt, M.OPS.add k x m, ids, acc))
(ctxt, M.OPS.empty, ids, acc)
(M.OPS.bindings (fst M.boxed))
>>=? fun (ctxt, m, ids, acc) ->
let module M = struct
module OPS = M.OPS
type key = M.key
type value = M.value
let key_ty = M.key_ty
let boxed = (m, snd M.boxed)
end in
return
( ctxt,
(module M : Boxed_map with type key = M.key and type value = M.value),
ids,
acc )
| (Option_t (_, _, true), None) ->
return (ctxt, None, ids, acc)
| (List_t (_, _, false), v) ->
return (ctxt, v, ids, acc)
| (Map_t (_, _, _, false), v) ->
return (ctxt, v, ids, acc)
| (Option_t (_, _, false), None) ->
return (ctxt, None, ids, acc)
| (Pair_t (_, _, _, false), v) ->
return (ctxt, v, ids, acc)
| (Union_t (_, _, _, false), v) ->
return (ctxt, v, ids, acc)
| (Option_t (_, _, false), v) ->
return (ctxt, v, ids, acc)
| (Chain_id_t _, v) ->
return (ctxt, v, ids, acc)
| (Set_t (_, _), v) ->
return (ctxt, v, ids, acc)
| (Unit_t _, v) ->
return (ctxt, v, ids, acc)
| (Int_t _, v) ->
return (ctxt, v, ids, acc)
| (Nat_t _, v) ->
return (ctxt, v, ids, acc)
| (Signature_t _, v) ->
return (ctxt, v, ids, acc)
| (String_t _, v) ->
return (ctxt, v, ids, acc)
| (Bytes_t _, v) ->
return (ctxt, v, ids, acc)
| (Mutez_t _, v) ->
return (ctxt, v, ids, acc)
| (Key_hash_t _, v) ->
return (ctxt, v, ids, acc)
| (Key_t _, v) ->
return (ctxt, v, ids, acc)
| (Timestamp_t _, v) ->
return (ctxt, v, ids, acc)
| (Address_t _, v) ->
return (ctxt, v, ids, acc)
| (Bool_t _, v) ->
return (ctxt, v, ids, acc)
| (Lambda_t (_, _, _), v) ->
return (ctxt, v, ids, acc)
| (Contract_t (_, _), v) ->
return (ctxt, v, ids, acc)
| (Operation_t _, _) ->
assert false
(* called only on parameters and storage, which cannot contain operations *)
let collect_big_maps ctxt ty x =
let rec collect :
type a. context -> a ty -> a -> Ids.t -> (Ids.t * context) tzresult =
fun ctxt ty x acc ->
match (ty, x) with
| (Big_map_t (_, _, _), {id = Some id}) ->
Gas.consume ctxt Typecheck_costs.cycle
>>? fun ctxt -> ok (Ids.add id acc, ctxt)
| (Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr)) ->
collect ctxt tyl xl acc >>? fun (acc, ctxt) -> collect ctxt tyr xr acc
| (Union_t ((ty, _), (_, _), _, true), L x) ->
collect ctxt ty x acc
| (Union_t ((_, _), (ty, _), _, true), R x) ->
collect ctxt ty x acc
| (Option_t (ty, _, true), Some x) ->
collect ctxt ty x acc
| (List_t (ty, _, true), l) ->
List.fold_left
(fun acc x -> acc >>? fun (acc, ctxt) -> collect ctxt ty x acc)
(ok (acc, ctxt))
l
| (Map_t (_, ty, _, true), m) ->
map_fold
(fun _ v acc -> acc >>? fun (acc, ctxt) -> collect ctxt ty v acc)
m
(ok (acc, ctxt))
| (List_t (_, _, false), _) ->
ok (acc, ctxt)
| (Map_t (_, _, _, false), _) ->
ok (acc, ctxt)
| (Big_map_t (_, _, _), {id = None}) ->
ok (acc, ctxt)
| (Option_t (_, _, true), None) ->
ok (acc, ctxt)
| (Option_t (_, _, false), _) ->
ok (acc, ctxt)
| (Union_t (_, _, _, false), _) ->
ok (acc, ctxt)
| (Pair_t (_, _, _, false), _) ->
ok (acc, ctxt)
| (Chain_id_t _, _) ->
ok (acc, ctxt)
| (Set_t (_, _), _) ->
ok (acc, ctxt)
| (Unit_t _, _) ->
ok (acc, ctxt)
| (Int_t _, _) ->
ok (acc, ctxt)
| (Nat_t _, _) ->
ok (acc, ctxt)
| (Signature_t _, _) ->
ok (acc, ctxt)
| (String_t _, _) ->
ok (acc, ctxt)
| (Bytes_t _, _) ->
ok (acc, ctxt)
| (Mutez_t _, _) ->
ok (acc, ctxt)
| (Key_hash_t _, _) ->
ok (acc, ctxt)
| (Key_t _, _) ->
ok (acc, ctxt)
| (Timestamp_t _, _) ->
ok (acc, ctxt)
| (Address_t _, _) ->
ok (acc, ctxt)
| (Bool_t _, _) ->
ok (acc, ctxt)
| (Lambda_t (_, _, _), _) ->
ok (acc, ctxt)
| (Contract_t (_, _), _) ->
ok (acc, ctxt)
| (Operation_t _, _) ->
assert false
(* called only on parameters and storage, which cannot contain operations *)
in
Lwt.return (collect ctxt ty x no_big_map_id)
let extract_big_map_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v =
let to_duplicate = Ids.diff to_duplicate to_update in
let fresh =
if temporary then fun c -> return (Big_map.fresh_temporary c)
else Big_map.fresh
in
extract_big_map_updates ctxt fresh mode to_duplicate [] ty v
>>=? fun (ctxt, v, alive, diffs) ->
let diffs =
if temporary then diffs
else
let dead = Ids.diff to_update alive in
Ids.fold (fun id acc -> Contract.Clear id :: acc) dead [] :: diffs
in
match diffs with
| [] ->
return (v, None, ctxt)
| diffs ->
return (v, Some (List.flatten diffs (* do not reverse *)), ctxt)
let list_of_big_map_ids ids = Ids.elements ids
Script_ir_translator.v
(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Require Import TypingFlags.Loader.
Unset Guard Checking.
Require Import Tezos.Environment.
Require Tezos.Alpha_context.
Require Tezos.Michelson_v1_gas.
Require Tezos.Script_expr_hash.
Require Tezos.Script_ir_annot.
Require Tezos.Script_tc_errors.
Require Tezos.Script_typed_ir.
Import Alpha_context.
Import Micheline.
Import Script.
Import Script_typed_ir.
Import Script_tc_errors.
Import Script_ir_annot.
Module Typecheck_costs := Michelson_v1_gas.Cost_of.Typechecking.
Module Unparse_costs := Michelson_v1_gas.Cost_of.Unparse.
Reserved Notation "'ex_comparable_ty".
Inductive ex_comparable_ty_gadt : Set :=
| Ex_comparable_ty : forall {a : Set},
Script_typed_ir.comparable_ty a -> ex_comparable_ty_gadt
where "'ex_comparable_ty" := (ex_comparable_ty_gadt).
Definition ex_comparable_ty := 'ex_comparable_ty.
Reserved Notation "'ex_ty".
Inductive ex_ty_gadt : Set :=
| Ex_ty : forall {a : Set}, Script_typed_ir.ty a -> ex_ty_gadt
where "'ex_ty" := (ex_ty_gadt).
Definition ex_ty := 'ex_ty.
Reserved Notation "'ex_stack_ty".
Inductive ex_stack_ty_gadt : Set :=
| Ex_stack_ty : forall {a : Set}, Script_typed_ir.stack_ty a -> ex_stack_ty_gadt
where "'ex_stack_ty" := (ex_stack_ty_gadt).
Definition ex_stack_ty := 'ex_stack_ty.
Module tc_context.
Module Toplevel.
Record record {storage_type param_type root_name
legacy_create_contract_literal : Set} := {
storage_type : storage_type;
param_type : param_type;
root_name : root_name;
legacy_create_contract_literal : legacy_create_contract_literal }.
Arguments record : clear implicits.
End Toplevel.
Definition Toplevel := Toplevel.record.
End tc_context.
Reserved Notation "'tc_context".
Inductive tc_context_gadt : Set :=
| Lambda : tc_context_gadt
| Dip : forall {a : Set},
Script_typed_ir.stack_ty a -> tc_context_gadt -> tc_context_gadt
| Toplevel : forall {param sto : Set},
tc_context.Toplevel (Script_typed_ir.ty sto) (Script_typed_ir.ty param)
(option string) bool -> tc_context_gadt
where "'tc_context" := (tc_context_gadt).
Definition tc_context := 'tc_context.
Inductive unparsing_mode : Set :=
| Optimized : unparsing_mode
| Readable : unparsing_mode.
Definition type_logger :=
Z -> list (Alpha_context.Script.expr * Alpha_context.Script.annot) ->
list (Alpha_context.Script.expr * Alpha_context.Script.annot) -> unit.
Definition add_dip {A : Set}
(ty : Script_typed_ir.ty A) (annot : option Script_typed_ir.var_annot)
(prev : tc_context) : tc_context :=
match prev with
| Lambda | Toplevel _ =>
Dip (Script_typed_ir.Item_t ty Script_typed_ir.Empty_t annot) prev
| Dip stack _ => Dip (Script_typed_ir.Item_t ty stack annot) prev
end.
Fixpoint comparable_type_size {a t : Set}
(ty : Script_typed_ir.comparable_struct t a) {struct ty} : Z :=
match ty with
| Script_typed_ir.Int_key _ => 1
| Script_typed_ir.Nat_key _ => 1
| Script_typed_ir.String_key _ => 1
| Script_typed_ir.Bytes_key _ => 1
| Script_typed_ir.Mutez_key _ => 1
| Script_typed_ir.Bool_key _ => 1
| Script_typed_ir.Key_hash_key _ => 1
| Script_typed_ir.Timestamp_key _ => 1
| Script_typed_ir.Address_key _ => 1
| Script_typed_ir.Pair_key _ (__t_value, _) _ =>
Pervasives.op_plus 1 (comparable_type_size __t_value)
end.
Fixpoint type_size {t : Set} (ty : Script_typed_ir.ty t) {struct ty} : Z :=
match ty with
| Script_typed_ir.Unit_t _ => 1
| Script_typed_ir.Int_t _ => 1
| Script_typed_ir.Nat_t _ => 1
| Script_typed_ir.Signature_t _ => 1
| Script_typed_ir.Bytes_t _ => 1
| Script_typed_ir.String_t _ => 1
| Script_typed_ir.Mutez_t _ => 1
| Script_typed_ir.Key_hash_t _ => 1
| Script_typed_ir.Key_t _ => 1
| Script_typed_ir.Timestamp_t _ => 1
| Script_typed_ir.Address_t _ => 1
| Script_typed_ir.Bool_t _ => 1
| Script_typed_ir.Operation_t _ => 1
| Script_typed_ir.Pair_t (l, _, _) (r, _, _) _ _ =>
Pervasives.op_plus (Pervasives.op_plus 1 (type_size l)) (type_size r)
| Script_typed_ir.Union_t (l, _) (r, _) _ _ =>
Pervasives.op_plus (Pervasives.op_plus 1 (type_size l)) (type_size r)
| Script_typed_ir.Lambda_t arg ret _ =>
Pervasives.op_plus (Pervasives.op_plus 1 (type_size arg)) (type_size ret)
| Script_typed_ir.Option_t __t_value _ _ =>
Pervasives.op_plus 1 (type_size __t_value)
| Script_typed_ir.List_t __t_value _ _ =>
Pervasives.op_plus 1 (type_size __t_value)
| Script_typed_ir.Set_t k _ => Pervasives.op_plus 1 (comparable_type_size k)
| Script_typed_ir.Map_t k v _ _ =>
Pervasives.op_plus (Pervasives.op_plus 1 (comparable_type_size k))
(type_size v)
| Script_typed_ir.Big_map_t k v _ =>
Pervasives.op_plus (Pervasives.op_plus 1 (comparable_type_size k))
(type_size v)
| Script_typed_ir.Contract_t arg _ => Pervasives.op_plus 1 (type_size arg)
| Script_typed_ir.Chain_id_t _ => 1
end.
Fixpoint type_size_of_stack_head {st : Set}
(stack : Script_typed_ir.stack_ty st) (up_to : Z) {struct stack} : Z :=
match stack with
| Script_typed_ir.Empty_t => 0
| Script_typed_ir.Item_t head tail _annot =>
if (|Compare.Int|).(Compare.S.op_gt) up_to 0 then
(|Compare.Int|).(Compare.S.max) (type_size head)
(type_size_of_stack_head tail (Pervasives.op_minus up_to 1))
else
0
end.
Definition number_of_generated_growing_types {a b : Set}
(function_parameter : Script_typed_ir.instr b a) : Z :=
match function_parameter with
| Script_typed_ir.Drop => 0
| Script_typed_ir.Dup => 0
| Script_typed_ir.Swap => 0
| Script_typed_ir.Const _ => 1
| Script_typed_ir.Cons_pair => 1
| Script_typed_ir.Car => 0
| Script_typed_ir.Cdr => 0
| Script_typed_ir.Cons_some => 1
| Script_typed_ir.Cons_none _ => 1
| Script_typed_ir.If_none _ _ => 0
| Script_typed_ir.Left => 0
| Script_typed_ir.Right => 0
| Script_typed_ir.If_left _ _ => 0
| Script_typed_ir.Cons_list => 1
| Script_typed_ir.Nil => 1
| Script_typed_ir.If_cons _ _ => 0
| Script_typed_ir.List_map _ => 1
| Script_typed_ir.List_size => 0
| Script_typed_ir.List_iter _ => 1
| Script_typed_ir.Empty_set _ => 1
| Script_typed_ir.Set_iter _ => 0
| Script_typed_ir.Set_mem => 0
| Script_typed_ir.Set_update => 0
| Script_typed_ir.Set_size => 0
| Script_typed_ir.Empty_map _ _ => 1
| Script_typed_ir.Map_map _ => 1
| Script_typed_ir.Map_iter _ => 1
| Script_typed_ir.Map_mem => 0
| Script_typed_ir.Map_get => 0
| Script_typed_ir.Map_update => 0
| Script_typed_ir.Map_size => 0
| Script_typed_ir.Empty_big_map _ _ => 1
| Script_typed_ir.Big_map_get => 0
| Script_typed_ir.Big_map_update => 0
| Script_typed_ir.Big_map_mem => 0
| Script_typed_ir.Concat_string => 0
| Script_typed_ir.Concat_string_pair => 0
| Script_typed_ir.Slice_string => 0
| Script_typed_ir.String_size => 0
| Script_typed_ir.Concat_bytes => 0
| Script_typed_ir.Concat_bytes_pair => 0
| Script_typed_ir.Slice_bytes => 0
| Script_typed_ir.Bytes_size => 0
| Script_typed_ir.Add_seconds_to_timestamp => 0
| Script_typed_ir.Add_timestamp_to_seconds => 0
| Script_typed_ir.Sub_timestamp_seconds => 0
| Script_typed_ir.Diff_timestamps => 0
| Script_typed_ir.Add_tez => 0
| Script_typed_ir.Sub_tez => 0
| Script_typed_ir.Mul_teznat => 0
| Script_typed_ir.Mul_nattez => 0
| Script_typed_ir.Ediv_teznat => 0
| Script_typed_ir.Ediv_tez => 0
| Script_typed_ir.Or => 0
| Script_typed_ir.And => 0
| Script_typed_ir.Xor => 0
| Script_typed_ir.Not => 0
| Script_typed_ir.Is_nat => 0
| Script_typed_ir.Neg_nat => 0
| Script_typed_ir.Neg_int => 0
| Script_typed_ir.Abs_int => 0
| Script_typed_ir.Int_nat => 0
| Script_typed_ir.Add_intint => 0
| Script_typed_ir.Add_intnat => 0
| Script_typed_ir.Add_natint => 0
| Script_typed_ir.Add_natnat => 0
| Script_typed_ir.Sub_int => 0
| Script_typed_ir.Mul_intint => 0
| Script_typed_ir.Mul_intnat => 0
| Script_typed_ir.Mul_natint => 0
| Script_typed_ir.Mul_natnat => 0
| Script_typed_ir.Ediv_intint => 0
| Script_typed_ir.Ediv_intnat => 0
| Script_typed_ir.Ediv_natint => 0
| Script_typed_ir.Ediv_natnat => 0
| Script_typed_ir.Lsl_nat => 0
| Script_typed_ir.Lsr_nat => 0
| Script_typed_ir.Or_nat => 0
| Script_typed_ir.And_nat => 0
| Script_typed_ir.And_int_nat => 0
| Script_typed_ir.Xor_nat => 0
| Script_typed_ir.Not_nat => 0
| Script_typed_ir.Not_int => 0
| Script_typed_ir.Seq _ _ => 0
| Script_typed_ir.If _ _ => 0
| Script_typed_ir.Loop _ => 0
| Script_typed_ir.Loop_left _ => 0
| Script_typed_ir.Dip _ => 0
| Script_typed_ir.Exec => 0
| Script_typed_ir.Apply _ => 0
| Script_typed_ir.Lambda _ => 1
| Script_typed_ir.Failwith _ => 1
| Script_typed_ir.Nop => 0
| Script_typed_ir.Compare _ => 1
| Script_typed_ir.Eq => 0
| Script_typed_ir.Neq => 0
| Script_typed_ir.Lt => 0
| Script_typed_ir.Gt => 0
| Script_typed_ir.Le => 0
| Script_typed_ir.Ge => 0
| Script_typed_ir.Address => 0
| Script_typed_ir.Contract _ _ => 1
| Script_typed_ir.Transfer_tokens => 1
| Script_typed_ir.Create_account => 0
| Script_typed_ir.Implicit_account => 0
| Script_typed_ir.Create_contract _ _ _ _ => 1
| Script_typed_ir.Create_contract_2 _ _ _ _ => 1
| Script_typed_ir.Now => 0
| Script_typed_ir.Balance => 0
| Script_typed_ir.Check_signature => 0
| Script_typed_ir.Hash_key => 0
| Script_typed_ir.Blake2b => 0
| Script_typed_ir.Sha256 => 0
| Script_typed_ir.Sha512 => 0
| Script_typed_ir.Steps_to_quota => 0
| Script_typed_ir.Source => 0
| Script_typed_ir.Sender => 0
| Script_typed_ir.Self _ _ => 1
| Script_typed_ir.Amount => 0
| Script_typed_ir.Set_delegate => 0
| Script_typed_ir.Pack _ => 0
| Script_typed_ir.Unpack _ => 1
| Script_typed_ir.Dig _ _ => 0
| Script_typed_ir.Dug _ _ => 0
| Script_typed_ir.Dipn _ _ _ => 0
| Script_typed_ir.Dropn _ _ => 0
| Script_typed_ir.ChainId => 0
end.
Definition location {A B : Set} (function_parameter : Micheline.node A B) : A :=
let
'Micheline.Prim loc _ _ _ | Micheline.Int loc _ | Micheline.String loc _ |
Micheline.Bytes loc _ | Micheline.Seq loc _ := function_parameter in
loc.
Definition kind {A B : Set} (function_parameter : Micheline.node A B)
: Script_tc_errors.kind :=
match function_parameter with
| Micheline.Int _ _ => Script_tc_errors.Int_kind
| Micheline.String _ _ => Script_tc_errors.String_kind
| Micheline.Bytes _ _ => Script_tc_errors.Bytes_kind
| Micheline.Prim _ _ _ _ => Script_tc_errors.Prim_kind
| Micheline.Seq _ _ => Script_tc_errors.Seq_kind
end.
Definition namespace (function_parameter : Alpha_context.Script.prim)
: Script_tc_errors.namespace :=
match function_parameter with
|
Alpha_context.Script.K_parameter | Alpha_context.Script.K_storage |
Alpha_context.Script.K_code => Script_tc_errors.Keyword_namespace
|
Alpha_context.Script.D_False | Alpha_context.Script.D_Elt |
Alpha_context.Script.D_Left | Alpha_context.Script.D_None |
Alpha_context.Script.D_Pair | Alpha_context.Script.D_Right |
Alpha_context.Script.D_Some | Alpha_context.Script.D_True |
Alpha_context.Script.D_Unit => Script_tc_errors.Constant_namespace
|
Alpha_context.Script.I_PACK | Alpha_context.Script.I_UNPACK |
Alpha_context.Script.I_BLAKE2B | Alpha_context.Script.I_SHA256 |
Alpha_context.Script.I_SHA512 | Alpha_context.Script.I_ABS |
Alpha_context.Script.I_ADD | Alpha_context.Script.I_AMOUNT |
Alpha_context.Script.I_AND | Alpha_context.Script.I_BALANCE |
Alpha_context.Script.I_CAR | Alpha_context.Script.I_CDR |
Alpha_context.Script.I_CHAIN_ID | Alpha_context.Script.I_CHECK_SIGNATURE |
Alpha_context.Script.I_COMPARE | Alpha_context.Script.I_CONCAT |
Alpha_context.Script.I_CONS | Alpha_context.Script.I_CREATE_ACCOUNT |
Alpha_context.Script.I_CREATE_CONTRACT |
Alpha_context.Script.I_IMPLICIT_ACCOUNT | Alpha_context.Script.I_DIP |
Alpha_context.Script.I_DROP | Alpha_context.Script.I_DUP |
Alpha_context.Script.I_EDIV | Alpha_context.Script.I_EMPTY_BIG_MAP |
Alpha_context.Script.I_EMPTY_MAP | Alpha_context.Script.I_EMPTY_SET |
Alpha_context.Script.I_EQ | Alpha_context.Script.I_EXEC |
Alpha_context.Script.I_APPLY | Alpha_context.Script.I_FAILWITH |
Alpha_context.Script.I_GE | Alpha_context.Script.I_GET |
Alpha_context.Script.I_GT | Alpha_context.Script.I_HASH_KEY |
Alpha_context.Script.I_IF | Alpha_context.Script.I_IF_CONS |
Alpha_context.Script.I_IF_LEFT | Alpha_context.Script.I_IF_NONE |
Alpha_context.Script.I_INT | Alpha_context.Script.I_LAMBDA |
Alpha_context.Script.I_LE | Alpha_context.Script.I_LEFT |
Alpha_context.Script.I_LOOP | Alpha_context.Script.I_LSL |
Alpha_context.Script.I_LSR | Alpha_context.Script.I_LT |
Alpha_context.Script.I_MAP | Alpha_context.Script.I_MEM |
Alpha_context.Script.I_MUL | Alpha_context.Script.I_NEG |
Alpha_context.Script.I_NEQ | Alpha_context.Script.I_NIL |
Alpha_context.Script.I_NONE | Alpha_context.Script.I_NOT |
Alpha_context.Script.I_NOW | Alpha_context.Script.I_OR |
Alpha_context.Script.I_PAIR | Alpha_context.Script.I_PUSH |
Alpha_context.Script.I_RIGHT | Alpha_context.Script.I_SIZE |
Alpha_context.Script.I_SOME | Alpha_context.Script.I_SOURCE |
Alpha_context.Script.I_SENDER | Alpha_context.Script.I_SELF |
Alpha_context.Script.I_SLICE | Alpha_context.Script.I_STEPS_TO_QUOTA |
Alpha_context.Script.I_SUB | Alpha_context.Script.I_SWAP |
Alpha_context.Script.I_TRANSFER_TOKENS | Alpha_context.Script.I_SET_DELEGATE
| Alpha_context.Script.I_UNIT | Alpha_context.Script.I_UPDATE |
Alpha_context.Script.I_XOR | Alpha_context.Script.I_ITER |
Alpha_context.Script.I_LOOP_LEFT | Alpha_context.Script.I_ADDRESS |
Alpha_context.Script.I_CONTRACT | Alpha_context.Script.I_ISNAT |
Alpha_context.Script.I_CAST | Alpha_context.Script.I_RENAME |
Alpha_context.Script.I_DIG | Alpha_context.Script.I_DUG =>
Script_tc_errors.Instr_namespace
|
Alpha_context.Script.T_bool | Alpha_context.Script.T_contract |
Alpha_context.Script.T_int | Alpha_context.Script.T_key |
Alpha_context.Script.T_key_hash | Alpha_context.Script.T_lambda |
Alpha_context.Script.T_list | Alpha_context.Script.T_map |
Alpha_context.Script.T_big_map | Alpha_context.Script.T_nat |
Alpha_context.Script.T_option | Alpha_context.Script.T_or |
Alpha_context.Script.T_pair | Alpha_context.Script.T_set |
Alpha_context.Script.T_signature | Alpha_context.Script.T_string |
Alpha_context.Script.T_bytes | Alpha_context.Script.T_mutez |
Alpha_context.Script.T_timestamp | Alpha_context.Script.T_unit |
Alpha_context.Script.T_operation | Alpha_context.Script.T_address |
Alpha_context.Script.T_chain_id => Script_tc_errors.Type_namespace
end.
Definition unexpected
(expr : Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
(exp_kinds : list Script_tc_errors.kind) (exp_ns : Script_tc_errors.namespace)
(exp_prims : list Alpha_context.Script.prim) : Error_monad.__error :=
match expr with
| Micheline.Int loc _ => extensible_type_value
| Micheline.String loc _ => extensible_type_value
| Micheline.Bytes loc _ => extensible_type_value
| Micheline.Seq loc _ => extensible_type_value
| Micheline.Prim loc name _ _ =>
match ((namespace name), exp_ns) with
|
(Script_tc_errors.Type_namespace, Script_tc_errors.Type_namespace) |
(Script_tc_errors.Instr_namespace, Script_tc_errors.Instr_namespace) |
(Script_tc_errors.Constant_namespace, Script_tc_errors.Constant_namespace)
=> extensible_type_value
| (ns, _) => extensible_type_value
end
end.
Definition check_kind {A : Set}
(kinds : list Script_tc_errors.kind)
(expr : Micheline.node Alpha_context.Script.location A)
: Lwt.t (Error_monad.tzresult unit) :=
let kind := kind expr in
if List.mem kind kinds then
Error_monad.return_unit
else
let loc := location expr in
Error_monad.fail extensible_type_value.
Definition wrap_compare {A B : Set}
(compare : A -> B -> (|Compare.Int|).(Compare.S.t)) (a : A) (b : B) : Z :=
let res := compare a b in
if (|Compare.Int|).(Compare.S.op_eq) res 0 then
0
else
if (|Compare.Int|).(Compare.S.op_gt) res 0 then
1
else
(-1).
Fixpoint compare_comparable {a s : Set}
(kind : Script_typed_ir.comparable_struct a s) {struct kind} : a -> a -> Z :=
match kind with
| Script_typed_ir.String_key _ =>
wrap_compare (|Compare.String|).(Compare.S.compare)
| Script_typed_ir.Bool_key _ =>
wrap_compare (|Compare.Bool|).(Compare.S.compare)
| Script_typed_ir.Mutez_key _ => wrap_compare Alpha_context.Tez.compare
| Script_typed_ir.Key_hash_key _ =>
wrap_compare (|Signature.Public_key_hash|).(S.SPublic_key_hash.compare)
| Script_typed_ir.Int_key _ => wrap_compare Alpha_context.Script_int.compare
| Script_typed_ir.Nat_key _ => wrap_compare Alpha_context.Script_int.compare
| Script_typed_ir.Timestamp_key _ =>
wrap_compare Alpha_context.Script_timestamp.compare
| Script_typed_ir.Address_key _ =>
Pervasives.op_atat wrap_compare
(fun function_parameter =>
let '(x, ex) := function_parameter in
fun function_parameter =>
let '(y, ey) := function_parameter in
let lres := Alpha_context.Contract.compare x y in
if (|Compare.Int|).(Compare.S.op_eq) lres 0 then
(|Compare.String|).(Compare.S.compare) ex ey
else
lres)
| Script_typed_ir.Bytes_key _ => wrap_compare MBytes.compare
| Script_typed_ir.Pair_key (tl, _) (tr, _) _ =>
fun function_parameter =>
let '(lx, rx) := function_parameter in
fun function_parameter =>
let '(ly, ry) := function_parameter in
let lres := compare_comparable tl lx ly in
if (|Compare.Int|).(Compare.S.op_eq) lres 0 then
compare_comparable tr rx ry
else
lres
end.
Definition empty_set {a : Set} (ty : Script_typed_ir.comparable_ty a)
: Script_typed_ir.set a :=
let OPS :=
__Set.Make
(let t := a in
let compare := compare_comparable ty in
existT _ _
{|
Compare.COMPARABLE.compare := compare
|}) in
let elt := a in
let elt_ty := ty in
let boxed := (|OPS|).(S.SET.empty) in
let size := 0 in
existT _ _
{|
Script_typed_ir.Boxed_set.elt_ty := elt_ty;
Script_typed_ir.Boxed_set.boxed := boxed;
Script_typed_ir.Boxed_set.size := size
|}.
Definition set_update {a : Set} (v : a) (b : bool) (Box : Script_typed_ir.set a)
: Script_typed_ir.set a :=
let elt := a in
let elt_ty := (|Box|).(Script_typed_ir.Boxed_set.elt_ty) in
let OPS := (|Box|).(Script_typed_ir.Boxed_set.OPS) in
let boxed :=
if b then
(|Box|).(Script_typed_ir.Boxed_set.OPS).(S.SET.add) v
(|Box|).(Script_typed_ir.Boxed_set.boxed)
else
(|Box|).(Script_typed_ir.Boxed_set.OPS).(S.SET.remove) v
(|Box|).(Script_typed_ir.Boxed_set.boxed) in
let size :=
let mem :=
(|Box|).(Script_typed_ir.Boxed_set.OPS).(S.SET.mem) v
(|Box|).(Script_typed_ir.Boxed_set.boxed) in
if mem then
if b then
(|Box|).(Script_typed_ir.Boxed_set.size)
else
Pervasives.op_minus (|Box|).(Script_typed_ir.Boxed_set.size) 1
else
if b then
Pervasives.op_plus (|Box|).(Script_typed_ir.Boxed_set.size) 1
else
(|Box|).(Script_typed_ir.Boxed_set.size) in
existT _ _
{|
Script_typed_ir.Boxed_set.elt_ty := elt_ty;
Script_typed_ir.Boxed_set.boxed := boxed;
Script_typed_ir.Boxed_set.size := size
|}.
Definition set_mem {elt : Set} (v : elt) (Box : Script_typed_ir.set elt)
: bool :=
(|Box|).(Script_typed_ir.Boxed_set.OPS).(S.SET.mem) v
(|Box|).(Script_typed_ir.Boxed_set.boxed).
Definition set_fold {acc elt : Set}
(f : elt -> acc -> acc) (Box : Script_typed_ir.set elt) : acc -> acc :=
(|Box|).(Script_typed_ir.Boxed_set.OPS).(S.SET.fold) f
(|Box|).(Script_typed_ir.Boxed_set.boxed).
Definition set_size {elt : Set} (Box : Script_typed_ir.set elt)
: Alpha_context.Script_int.num Alpha_context.Script_int.n :=
Alpha_context.Script_int.abs
(Alpha_context.Script_int.of_int (|Box|).(Script_typed_ir.Boxed_set.size)).
Definition map_key_ty {a b : Set} (Box : Script_typed_ir.map a b)
: Script_typed_ir.comparable_ty a :=
(|Box|).(Script_typed_ir.Boxed_map.key_ty).
Definition empty_map {a b : Set} (ty : Script_typed_ir.comparable_ty a)
: Script_typed_ir.map a b :=
let OPS :=
Map.Make
(let t := a in
let compare := compare_comparable ty in
existT _ _
{|
Compare.COMPARABLE.compare := compare
|}) in
let key := a in
let value := b in
let key_ty := ty in
let boxed := ((|OPS|).(S.MAP.empty), 0) in
existT _ _
{|
Script_typed_ir.Boxed_map.key_ty := key_ty;
Script_typed_ir.Boxed_map.boxed := boxed
|}.
Definition map_get {key value : Set}
(k : key) (Box : Script_typed_ir.map key value) : option value :=
(|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.find_opt) k
(Pervasives.fst (|Box|).(Script_typed_ir.Boxed_map.boxed)).
Definition map_update {a b : Set}
(k : a) (v : option b) (Box : Script_typed_ir.map a b)
: Script_typed_ir.map a b :=
let key := a in
let value := b in
let key_ty := (|Box|).(Script_typed_ir.Boxed_map.key_ty) in
let OPS := (|Box|).(Script_typed_ir.Boxed_map.OPS) in
let boxed :=
let '(map, size) := (|Box|).(Script_typed_ir.Boxed_map.boxed) in
let contains := (|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.mem) k map in
match v with
| Some v =>
(((|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.add) k v map),
(Pervasives.op_plus size
(if contains then
0
else
1)))
| None =>
(((|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.remove) k map),
(Pervasives.op_minus size
(if contains then
1
else
0)))
end in
existT _ _
{|
Script_typed_ir.Boxed_map.key_ty := key_ty;
Script_typed_ir.Boxed_map.boxed := boxed
|}.
Definition map_set {a b : Set} (k : a) (v : b) (Box : Script_typed_ir.map a b)
: Script_typed_ir.map a b :=
let key := a in
let value := b in
let key_ty := (|Box|).(Script_typed_ir.Boxed_map.key_ty) in
let OPS := (|Box|).(Script_typed_ir.Boxed_map.OPS) in
let boxed :=
let '(map, size) := (|Box|).(Script_typed_ir.Boxed_map.boxed) in
(((|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.add) k v map),
(if (|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.mem) k map then
size
else
Pervasives.op_plus size 1)) in
existT _ _
{|
Script_typed_ir.Boxed_map.key_ty := key_ty;
Script_typed_ir.Boxed_map.boxed := boxed
|}.
Definition map_mem {key value : Set}
(k : key) (Box : Script_typed_ir.map key value) : bool :=
(|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.mem) k
(Pervasives.fst (|Box|).(Script_typed_ir.Boxed_map.boxed)).
Definition map_fold {acc key value : Set}
(f : key -> value -> acc -> acc) (Box : Script_typed_ir.map key value)
: acc -> acc :=
(|Box|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.fold) f
(Pervasives.fst (|Box|).(Script_typed_ir.Boxed_map.boxed)).
Definition map_size {key value : Set} (Box : Script_typed_ir.map key value)
: Alpha_context.Script_int.num Alpha_context.Script_int.n :=
Alpha_context.Script_int.abs
(Alpha_context.Script_int.of_int
(Pervasives.snd (|Box|).(Script_typed_ir.Boxed_map.boxed))).
Fixpoint ty_of_comparable_ty {a s : Set}
(function_parameter : Script_typed_ir.comparable_struct a s)
{struct function_parameter} : Script_typed_ir.ty a :=
match function_parameter with
| Script_typed_ir.Int_key tname => Script_typed_ir.Int_t tname
| Script_typed_ir.Nat_key tname => Script_typed_ir.Nat_t tname
| Script_typed_ir.String_key tname => Script_typed_ir.String_t tname
| Script_typed_ir.Bytes_key tname => Script_typed_ir.Bytes_t tname
| Script_typed_ir.Mutez_key tname => Script_typed_ir.Mutez_t tname
| Script_typed_ir.Bool_key tname => Script_typed_ir.Bool_t tname
| Script_typed_ir.Key_hash_key tname => Script_typed_ir.Key_hash_t tname
| Script_typed_ir.Timestamp_key tname => Script_typed_ir.Timestamp_t tname
| Script_typed_ir.Address_key tname => Script_typed_ir.Address_t tname
| Script_typed_ir.Pair_key (l, al) (r, ar) tname =>
Script_typed_ir.Pair_t ((ty_of_comparable_ty l), al, None)
((ty_of_comparable_ty r), ar, None) tname false
end.
Fixpoint comparable_ty_of_ty {a : Set}
(function_parameter : Script_typed_ir.ty a) {struct function_parameter}
: option (Script_typed_ir.comparable_ty a) :=
match function_parameter with
| Script_typed_ir.Int_t tname => Some (Script_typed_ir.Int_key tname)
| Script_typed_ir.Nat_t tname => Some (Script_typed_ir.Nat_key tname)
| Script_typed_ir.String_t tname => Some (Script_typed_ir.String_key tname)
| Script_typed_ir.Bytes_t tname => Some (Script_typed_ir.Bytes_key tname)
| Script_typed_ir.Mutez_t tname => Some (Script_typed_ir.Mutez_key tname)
| Script_typed_ir.Bool_t tname => Some (Script_typed_ir.Bool_key tname)
| Script_typed_ir.Key_hash_t tname =>
Some (Script_typed_ir.Key_hash_key tname)
| Script_typed_ir.Timestamp_t tname =>
Some (Script_typed_ir.Timestamp_key tname)
| Script_typed_ir.Address_t tname => Some (Script_typed_ir.Address_key tname)
| Script_typed_ir.Pair_t (l, al, _) (r, ar, _) pname _ =>
match comparable_ty_of_ty r with
| None => None
| Some rty =>
match comparable_ty_of_ty l with
| None => None
| Some (Script_typed_ir.Pair_key _ _ _) => None
| Some (Script_typed_ir.Int_key tname) =>
Some
(Script_typed_ir.Pair_key ((Script_typed_ir.Int_key tname), al)
(rty, ar) pname)
| Some (Script_typed_ir.Nat_key tname) =>
Some
(Script_typed_ir.Pair_key ((Script_typed_ir.Nat_key tname), al)
(rty, ar) pname)
| Some (Script_typed_ir.String_key tname) =>
Some
(Script_typed_ir.Pair_key ((Script_typed_ir.String_key tname), al)
(rty, ar) pname)
| Some (Script_typed_ir.Bytes_key tname) =>
Some
(Script_typed_ir.Pair_key ((Script_typed_ir.Bytes_key tname), al)
(rty, ar) pname)
| Some (Script_typed_ir.Mutez_key tname) =>
Some
(Script_typed_ir.Pair_key ((Script_typed_ir.Mutez_key tname), al)
(rty, ar) pname)
| Some (Script_typed_ir.Bool_key tname) =>
Some
(Script_typed_ir.Pair_key ((Script_typed_ir.Bool_key tname), al)
(rty, ar) pname)
| Some (Script_typed_ir.Key_hash_key tname) =>
Some
(Script_typed_ir.Pair_key ((Script_typed_ir.Key_hash_key tname), al)
(rty, ar) pname)
| Some (Script_typed_ir.Timestamp_key tname) =>
Some
(Script_typed_ir.Pair_key ((Script_typed_ir.Timestamp_key tname), al)
(rty, ar) pname)
| Some (Script_typed_ir.Address_key tname) =>
Some
(Script_typed_ir.Pair_key ((Script_typed_ir.Address_key tname), al)
(rty, ar) pname)
end
end
| _ => None
end.
Definition add_field_annot {A B : Set}
(a : option Script_typed_ir.field_annot)
(var : option Script_typed_ir.var_annot)
(function_parameter : Micheline.node A B) : Micheline.node A B :=
match function_parameter with
| Micheline.Prim loc prim args annots =>
Micheline.Prim loc prim args
(Pervasives.op_at annots
(Pervasives.op_at (Script_ir_annot.unparse_field_annot a)
(Script_ir_annot.unparse_var_annot var)))
| expr => expr
end.
Fixpoint unparse_comparable_ty {a s : Set}
(function_parameter : Script_typed_ir.comparable_struct a s)
{struct function_parameter} : Alpha_context.Script.node :=
match function_parameter with
| Script_typed_ir.Int_key tname =>
Micheline.Prim (-1) Alpha_context.Script.T_int []
(Script_ir_annot.unparse_type_annot tname)
| Script_typed_ir.Nat_key tname =>
Micheline.Prim (-1) Alpha_context.Script.T_nat []
(Script_ir_annot.unparse_type_annot tname)
| Script_typed_ir.String_key tname =>
Micheline.Prim (-1) Alpha_context.Script.T_string []
(Script_ir_annot.unparse_type_annot tname)
| Script_typed_ir.Bytes_key tname =>
Micheline.Prim (-1) Alpha_context.Script.T_bytes []
(Script_ir_annot.unparse_type_annot tname)
| Script_typed_ir.Mutez_key tname =>
Micheline.Prim (-1) Alpha_context.Script.T_mutez []
(Script_ir_annot.unparse_type_annot tname)
| Script_typed_ir.Bool_key tname =>
Micheline.Prim (-1) Alpha_context.Script.T_bool []
(Script_ir_annot.unparse_type_annot tname)
| Script_typed_ir.Key_hash_key tname =>
Micheline.Prim (-1) Alpha_context.Script.T_key_hash []
(Script_ir_annot.unparse_type_annot tname)
| Script_typed_ir.Timestamp_key tname =>
Micheline.Prim (-1) Alpha_context.Script.T_timestamp []
(Script_ir_annot.unparse_type_annot tname)
| Script_typed_ir.Address_key tname =>
Micheline.Prim (-1) Alpha_context.Script.T_address []
(Script_ir_annot.unparse_type_annot tname)
| Script_typed_ir.Pair_key (l, al) (r, ar) pname =>
let tl := add_field_annot al None (unparse_comparable_ty l) in
let tr := add_field_annot ar None (unparse_comparable_ty r) in
Micheline.Prim (-1) Alpha_context.Script.T_pair [ tl; tr ]
(Script_ir_annot.unparse_type_annot pname)
end.
Fixpoint unparse_ty_no_lwt {a : Set}
(ctxt : Alpha_context.context) (ty : Script_typed_ir.ty a) {struct ctxt}
: Error_monad.tzresult (Alpha_context.Script.node * Alpha_context.context) :=
Error_monad.op_gtgtquestion
(Alpha_context.Gas.consume ctxt Unparse_costs.cycle)
(fun ctxt =>
let __return {B : Set}
(ctxt : Alpha_context.context)
(function_parameter : B * list (Micheline.node Z B) * Micheline.annot)
: Error_monad.tzresult (Micheline.node Z B * Alpha_context.context) :=
let '(name, args, annot) := function_parameter in
let __result_value := Micheline.Prim (-1) name args annot in
Error_monad.op_gtgtquestion
(Alpha_context.Gas.consume ctxt
(Unparse_costs.prim_cost (List.length args) annot))
(fun ctxt => Error_monad.ok (__result_value, ctxt)) in
match ty with
| Script_typed_ir.Unit_t tname =>
__return ctxt
(Alpha_context.Script.T_unit, [],
(Script_ir_annot.unparse_type_annot tname))
| Script_typed_ir.Int_t tname =>
__return ctxt
(Alpha_context.Script.T_int, [],
(Script_ir_annot.unparse_type_annot tname))
| Script_typed_ir.Nat_t tname =>
__return ctxt
(Alpha_context.Script.T_nat, [],
(Script_ir_annot.unparse_type_annot tname))
| Script_typed_ir.String_t tname =>
__return ctxt
(Alpha_context.Script.T_string, [],
(Script_ir_annot.unparse_type_annot tname))
| Script_typed_ir.Bytes_t tname =>
__return ctxt
(Alpha_context.Script.T_bytes, [],
(Script_ir_annot.unparse_type_annot tname))
| Script_typed_ir.Mutez_t tname =>
__return ctxt
(Alpha_context.Script.T_mutez, [],
(Script_ir_annot.unparse_type_annot tname))
| Script_typed_ir.Bool_t tname =>
__return ctxt
(Alpha_context.Script.T_bool, [],
(Script_ir_annot.unparse_type_annot tname))
| Script_typed_ir.Key_hash_t tname =>
__return ctxt
(Alpha_context.Script.T_key_hash, [],
(Script_ir_annot.unparse_type_annot tname))
| Script_typed_ir.Key_t tname =>
__return ctxt
(Alpha_context.Script.T_key, [],
(Script_ir_annot.unparse_type_annot tname))
| Script_typed_ir.Timestamp_t tname =>
__return ctxt
(Alpha_context.Script.T_timestamp, [],
(Script_ir_annot.unparse_type_annot tname))
| Script_typed_ir.Address_t tname =>
__return ctxt
(Alpha_context.Script.T_address, [],
(Script_ir_annot.unparse_type_annot tname))
| Script_typed_ir.Signature_t tname =>
__return ctxt
(Alpha_context.Script.T_signature, [],
(Script_ir_annot.unparse_type_annot tname))
| Script_typed_ir.Operation_t tname =>
__return ctxt
(Alpha_context.Script.T_operation, [],
(Script_ir_annot.unparse_type_annot tname))
| Script_typed_ir.Chain_id_t tname =>
__return ctxt
(Alpha_context.Script.T_chain_id, [],
(Script_ir_annot.unparse_type_annot tname))
| Script_typed_ir.Contract_t ut tname =>
Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt ut)
(fun function_parameter =>
let '(__t_value, ctxt) := function_parameter in
__return ctxt
(Alpha_context.Script.T_contract, [ __t_value ],
(Script_ir_annot.unparse_type_annot tname)))
|
Script_typed_ir.Pair_t (utl, l_field, l_var) (utr, r_field, r_var) tname
_ =>
let annot := Script_ir_annot.unparse_type_annot tname in
Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt utl)
(fun function_parameter =>
let '(utl, ctxt) := function_parameter in
let tl := add_field_annot l_field l_var utl in
Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
(fun function_parameter =>
let '(utr, ctxt) := function_parameter in
let tr := add_field_annot r_field r_var utr in
__return ctxt (Alpha_context.Script.T_pair, [ tl; tr ], annot)))
| Script_typed_ir.Union_t (utl, l_field) (utr, r_field) tname _ =>
let annot := Script_ir_annot.unparse_type_annot tname in
Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt utl)
(fun function_parameter =>
let '(utl, ctxt) := function_parameter in
let tl := add_field_annot l_field None utl in
Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
(fun function_parameter =>
let '(utr, ctxt) := function_parameter in
let tr := add_field_annot r_field None utr in
__return ctxt (Alpha_context.Script.T_or, [ tl; tr ], annot)))
| Script_typed_ir.Lambda_t uta utr tname =>
Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt uta)
(fun function_parameter =>
let '(ta, ctxt) := function_parameter in
Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
(fun function_parameter =>
let '(tr, ctxt) := function_parameter in
__return ctxt
(Alpha_context.Script.T_lambda, [ ta; tr ],
(Script_ir_annot.unparse_type_annot tname))))
| Script_typed_ir.Option_t ut tname _ =>
let annot := Script_ir_annot.unparse_type_annot tname in
Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt ut)
(fun function_parameter =>
let '(ut, ctxt) := function_parameter in
__return ctxt (Alpha_context.Script.T_option, [ ut ], annot))
| Script_typed_ir.List_t ut tname _ =>
Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt ut)
(fun function_parameter =>
let '(__t_value, ctxt) := function_parameter in
__return ctxt
(Alpha_context.Script.T_list, [ __t_value ],
(Script_ir_annot.unparse_type_annot tname)))
| Script_typed_ir.Set_t ut tname =>
let __t_value := unparse_comparable_ty ut in
__return ctxt
(Alpha_context.Script.T_set, [ __t_value ],
(Script_ir_annot.unparse_type_annot tname))
| Script_typed_ir.Map_t uta utr tname _ =>
let ta := unparse_comparable_ty uta in
Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
(fun function_parameter =>
let '(tr, ctxt) := function_parameter in
__return ctxt
(Alpha_context.Script.T_map, [ ta; tr ],
(Script_ir_annot.unparse_type_annot tname)))
| Script_typed_ir.Big_map_t uta utr tname =>
let ta := unparse_comparable_ty uta in
Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
(fun function_parameter =>
let '(tr, ctxt) := function_parameter in
__return ctxt
(Alpha_context.Script.T_big_map, [ ta; tr ],
(Script_ir_annot.unparse_type_annot tname)))
end).
Definition unparse_ty {A : Set}
(ctxt : Alpha_context.context) (ty : Script_typed_ir.ty A)
: Lwt.t
(Error_monad.tzresult (Alpha_context.Script.node * Alpha_context.context)) :=
Lwt.__return (unparse_ty_no_lwt ctxt ty).
Fixpoint strip_var_annots {A B : Set} (function_parameter : Micheline.node A B)
{struct function_parameter} : Micheline.node A B :=
match function_parameter with
| (Micheline.Int _ _ | Micheline.String _ _ | Micheline.Bytes _ _) as atom =>
atom
| Micheline.Seq loc args => Micheline.Seq loc (List.map strip_var_annots args)
| Micheline.Prim loc name args annots =>
let not_var_annot (s : string) : bool :=
(|Compare.Char|).(Compare.S.op_ltgt) (String.get s 0) "@" % char in
let annots := List.filter not_var_annot annots in
Micheline.Prim loc name (List.map strip_var_annots args) annots
end.
Definition serialize_ty_for_error {A : Set}
(ctxt : Alpha_context.context) (ty : Script_typed_ir.ty A)
: Error_monad.tzresult
(Micheline.canonical Alpha_context.Script.prim * Alpha_context.context) :=
Error_monad.op_gtpipequestion
(Pervasives.op_pipegt (unparse_ty_no_lwt ctxt ty)
(Error_monad.record_trace extensible_type_value))
(fun function_parameter =>
let '(ty, ctxt) := function_parameter in
((Micheline.strip_locations (strip_var_annots ty)), ctxt)).
Fixpoint unparse_stack {a : Set}
(ctxt : Alpha_context.context)
(function_parameter : Script_typed_ir.stack_ty a) {struct ctxt}
: Lwt.t
(Error_monad.tzresult
(list (Alpha_context.Script.expr * Alpha_context.Script.annot) *
Alpha_context.context)) :=
match function_parameter with
| Script_typed_ir.Empty_t => Error_monad.__return ([], ctxt)
| Script_typed_ir.Item_t ty rest annot =>
Error_monad.op_gtgteqquestion (unparse_ty ctxt ty)
(fun function_parameter =>
let '(uty, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (unparse_stack ctxt rest)
(fun function_parameter =>
let '(urest, ctxt) := function_parameter in
Error_monad.__return
((cons
((Micheline.strip_locations uty),
(Script_ir_annot.unparse_var_annot annot)) urest), ctxt)))
end.
Definition serialize_stack_for_error {A : Set}
(ctxt : Alpha_context.context) (stack_ty : Script_typed_ir.stack_ty A)
: Lwt.t
(Error_monad.tzresult
(list (Alpha_context.Script.expr * Alpha_context.Script.annot) *
Alpha_context.context)) :=
Error_monad.trace extensible_type_value (unparse_stack ctxt stack_ty).
Definition name_of_ty {a : Set} (function_parameter : Script_typed_ir.ty a)
: option Script_typed_ir.type_annot :=
match function_parameter with
| Script_typed_ir.Unit_t tname => tname
| Script_typed_ir.Int_t tname => tname
| Script_typed_ir.Nat_t tname => tname
| Script_typed_ir.String_t tname => tname
| Script_typed_ir.Bytes_t tname => tname
| Script_typed_ir.Mutez_t tname => tname
| Script_typed_ir.Bool_t tname => tname
| Script_typed_ir.Key_hash_t tname => tname
| Script_typed_ir.Key_t tname => tname
| Script_typed_ir.Timestamp_t tname => tname
| Script_typed_ir.Address_t tname => tname
| Script_typed_ir.Signature_t tname => tname
| Script_typed_ir.Operation_t tname => tname
| Script_typed_ir.Chain_id_t tname => tname
| Script_typed_ir.Contract_t _ tname => tname
| Script_typed_ir.Pair_t _ _ tname _ => tname
| Script_typed_ir.Union_t _ _ tname _ => tname
| Script_typed_ir.Lambda_t _ _ tname => tname
| Script_typed_ir.Option_t _ tname _ => tname
| Script_typed_ir.List_t _ tname _ => tname
| Script_typed_ir.Set_t _ tname => tname
| Script_typed_ir.Map_t _ _ tname _ => tname
| Script_typed_ir.Big_map_t _ _ tname => tname
end.
Reserved Notation "'eq".
Inductive eq_gadt : Set :=
| Eq : eq_gadt
where "'eq" := (fun (ta tb : Set) => eq_gadt).
Definition eq := 'eq.
Definition comparable_ty_eq {ta tb : Set}
(ctxt : Alpha_context.context) (ta : Script_typed_ir.comparable_ty ta)
(tb : Script_typed_ir.comparable_ty tb)
: Error_monad.tzresult
(eq (Script_typed_ir.comparable_ty ta) (Script_typed_ir.comparable_ty tb)) :=
match (ta, tb) with
| (Script_typed_ir.Int_key _, Script_typed_ir.Int_key _) => Pervasives.Ok Eq
| (Script_typed_ir.Nat_key _, Script_typed_ir.Nat_key _) => Pervasives.Ok Eq
| (Script_typed_ir.String_key _, Script_typed_ir.String_key _) =>
Pervasives.Ok Eq
| (Script_typed_ir.Bytes_key _, Script_typed_ir.Bytes_key _) =>
Pervasives.Ok Eq
| (Script_typed_ir.Mutez_key _, Script_typed_ir.Mutez_key _) =>
Pervasives.Ok Eq
| (Script_typed_ir.Bool_key _, Script_typed_ir.Bool_key _) => Pervasives.Ok Eq
| (Script_typed_ir.Key_hash_key _, Script_typed_ir.Key_hash_key _) =>
Pervasives.Ok Eq
| (Script_typed_ir.Timestamp_key _, Script_typed_ir.Timestamp_key _) =>
Pervasives.Ok Eq
| (Script_typed_ir.Address_key _, Script_typed_ir.Address_key _) =>
Pervasives.Ok Eq
| (_, _) =>
Error_monad.op_gtgtquestion
(serialize_ty_for_error ctxt (ty_of_comparable_ty ta))
(fun function_parameter =>
let '(ta, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(serialize_ty_for_error ctxt (ty_of_comparable_ty tb))
(fun function_parameter =>
let '(tb, _ctxt) := function_parameter in
Error_monad.__error_value extensible_type_value))
end.
Definition record_inconsistent {A B C : Set}
(ctxt : Alpha_context.context) (ta : Script_typed_ir.ty A)
(tb : Script_typed_ir.ty B)
: Error_monad.tzresult C -> Error_monad.tzresult C :=
Error_monad.record_trace_eval
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgtquestion (serialize_ty_for_error ctxt ta)
(fun function_parameter =>
let '(ta, ctxt) := function_parameter in
Error_monad.op_gtpipequestion (serialize_ty_for_error ctxt tb)
(fun function_parameter =>
let '(tb, _ctxt) := function_parameter in
extensible_type_value))).
Definition record_inconsistent_type_annotations {A B C : Set}
(ctxt : Alpha_context.context) (loc : Alpha_context.Script.location)
(ta : Script_typed_ir.ty A) (tb : Script_typed_ir.ty B)
: Error_monad.tzresult C -> Error_monad.tzresult C :=
Error_monad.record_trace_eval
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgtquestion (serialize_ty_for_error ctxt ta)
(fun function_parameter =>
let '(ta, ctxt) := function_parameter in
Error_monad.op_gtpipequestion (serialize_ty_for_error ctxt tb)
(fun function_parameter =>
let '(tb, _ctxt) := function_parameter in
extensible_type_value))).
Fixpoint ty_eq {ta tb : Set}
(ctxt : Alpha_context.context) (ta : Script_typed_ir.ty ta)
(tb : Script_typed_ir.ty tb) {struct ctxt}
: Error_monad.tzresult
(eq (Script_typed_ir.ty ta) (Script_typed_ir.ty tb) * Alpha_context.context) :=
let ok
(__eq_value : eq (Script_typed_ir.ty ta) (Script_typed_ir.ty tb))
(ctxt : Alpha_context.context) (nb_args : Z)
: Error_monad.tzresult
(eq (Script_typed_ir.ty ta) (Script_typed_ir.ty tb) *
Alpha_context.context) :=
Error_monad.op_gtgtquestion
(Alpha_context.Gas.consume ctxt
(Typecheck_costs.type_ (Pervasives.op_star 2 nb_args)))
(fun ctxt => Pervasives.Ok (__eq_value, ctxt)) in
Error_monad.op_gtgtquestion
(Alpha_context.Gas.consume ctxt Typecheck_costs.cycle)
(fun ctxt =>
match (ta, tb) with
| (Script_typed_ir.Unit_t _, Script_typed_ir.Unit_t _) => ok Eq ctxt 0
| (Script_typed_ir.Int_t _, Script_typed_ir.Int_t _) => ok Eq ctxt 0
| (Script_typed_ir.Nat_t _, Script_typed_ir.Nat_t _) => ok Eq ctxt 0
| (Script_typed_ir.Key_t _, Script_typed_ir.Key_t _) => ok Eq ctxt 0
| (Script_typed_ir.Key_hash_t _, Script_typed_ir.Key_hash_t _) =>
ok Eq ctxt 0
| (Script_typed_ir.String_t _, Script_typed_ir.String_t _) => ok Eq ctxt 0
| (Script_typed_ir.Bytes_t _, Script_typed_ir.Bytes_t _) => ok Eq ctxt 0
| (Script_typed_ir.Signature_t _, Script_typed_ir.Signature_t _) =>
ok Eq ctxt 0
| (Script_typed_ir.Mutez_t _, Script_typed_ir.Mutez_t _) => ok Eq ctxt 0
| (Script_typed_ir.Timestamp_t _, Script_typed_ir.Timestamp_t _) =>
ok Eq ctxt 0
| (Script_typed_ir.Chain_id_t _, Script_typed_ir.Chain_id_t _) =>
ok Eq ctxt 0
| (Script_typed_ir.Address_t _, Script_typed_ir.Address_t _) =>
ok Eq ctxt 0
| (Script_typed_ir.Bool_t _, Script_typed_ir.Bool_t _) => ok Eq ctxt 0
| (Script_typed_ir.Operation_t _, Script_typed_ir.Operation_t _) =>
ok Eq ctxt 0
| (Script_typed_ir.Map_t tal tar _ _, Script_typed_ir.Map_t tbl tbr _ _)
=>
Pervasives.op_pipegt
(Error_monad.op_gtgtquestion (comparable_ty_eq ctxt tal tbl)
(fun function_parameter =>
let 'Eq := function_parameter in
Error_monad.op_gtgtquestion (ty_eq ctxt tar tbr)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
|
(Script_typed_ir.Big_map_t tal tar _,
Script_typed_ir.Big_map_t tbl tbr _) =>
Pervasives.op_pipegt
(Error_monad.op_gtgtquestion (comparable_ty_eq ctxt tal tbl)
(fun function_parameter =>
let 'Eq := function_parameter in
Error_monad.op_gtgtquestion (ty_eq ctxt tar tbr)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
| (Script_typed_ir.Set_t ea _, Script_typed_ir.Set_t eb _) =>
Pervasives.op_pipegt
(Error_monad.op_gtgtquestion (comparable_ty_eq ctxt ea eb)
(fun function_parameter =>
let 'Eq := function_parameter in
ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
|
(Script_typed_ir.Pair_t (tal, _, _) (tar, _, _) _ _,
Script_typed_ir.Pair_t (tbl, _, _) (tbr, _, _) _ _) =>
Pervasives.op_pipegt
(Error_monad.op_gtgtquestion (ty_eq ctxt tal tbl)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgtquestion (ty_eq ctxt tar tbr)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
|
(Script_typed_ir.Union_t (tal, _) (tar, _) _ _,
Script_typed_ir.Union_t (tbl, _) (tbr, _) _ _) =>
Pervasives.op_pipegt
(Error_monad.op_gtgtquestion (ty_eq ctxt tal tbl)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgtquestion (ty_eq ctxt tar tbr)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
| (Script_typed_ir.Lambda_t tal tar _, Script_typed_ir.Lambda_t tbl tbr _)
=>
Pervasives.op_pipegt
(Error_monad.op_gtgtquestion (ty_eq ctxt tal tbl)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgtquestion (ty_eq ctxt tar tbr)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
| (Script_typed_ir.Contract_t tal _, Script_typed_ir.Contract_t tbl _) =>
Pervasives.op_pipegt
(Error_monad.op_gtgtquestion (ty_eq ctxt tal tbl)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
| (Script_typed_ir.Option_t tva _ _, Script_typed_ir.Option_t tvb _ _) =>
Pervasives.op_pipegt
(Error_monad.op_gtgtquestion (ty_eq ctxt tva tvb)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
| (Script_typed_ir.List_t tva _ _, Script_typed_ir.List_t tvb _ _) =>
Pervasives.op_pipegt
(Error_monad.op_gtgtquestion (ty_eq ctxt tva tvb)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
| (_, _) =>
Error_monad.op_gtgtquestion (serialize_ty_for_error ctxt ta)
(fun function_parameter =>
let '(ta, ctxt) := function_parameter in
Error_monad.op_gtgtquestion (serialize_ty_for_error ctxt tb)
(fun function_parameter =>
let '(tb, _ctxt) := function_parameter in
Error_monad.__error_value extensible_type_value))
end).
Fixpoint stack_ty_eq {ta tb : Set}
(ctxt : Alpha_context.context) (lvl : Z) (ta : Script_typed_ir.stack_ty ta)
(tb : Script_typed_ir.stack_ty tb) {struct ctxt}
: Error_monad.tzresult
(eq (Script_typed_ir.stack_ty ta) (Script_typed_ir.stack_ty tb) *
Alpha_context.context) :=
match (ta, tb) with
| (Script_typed_ir.Item_t tva ra _, Script_typed_ir.Item_t tvb rb _) =>
Error_monad.op_gtgtquestion
(Pervasives.op_pipegt (ty_eq ctxt tva tvb)
(Error_monad.record_trace extensible_type_value))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(stack_ty_eq ctxt (Pervasives.op_plus lvl 1) ra rb)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Pervasives.Ok (Eq, ctxt)))
| (Script_typed_ir.Empty_t, Script_typed_ir.Empty_t) =>
Pervasives.Ok (Eq, ctxt)
| (_, _) => Error_monad.__error_value extensible_type_value
end.
Definition merge_comparable_types {ta : Set}
(legacy : bool) (ta : Script_typed_ir.comparable_ty ta)
(tb : Script_typed_ir.comparable_ty ta)
: Error_monad.tzresult (Script_typed_ir.comparable_ty ta) :=
match (ta, tb) with
| (Script_typed_ir.Int_key annot_a, Script_typed_ir.Int_key annot_b) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy annot_a annot_b)
(fun annot => Script_typed_ir.Int_key annot)
| (Script_typed_ir.Nat_key annot_a, Script_typed_ir.Nat_key annot_b) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy annot_a annot_b)
(fun annot => Script_typed_ir.Nat_key annot)
| (Script_typed_ir.String_key annot_a, Script_typed_ir.String_key annot_b) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy annot_a annot_b)
(fun annot => Script_typed_ir.String_key annot)
| (Script_typed_ir.Bytes_key annot_a, Script_typed_ir.Bytes_key annot_b) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy annot_a annot_b)
(fun annot => Script_typed_ir.Bytes_key annot)
| (Script_typed_ir.Mutez_key annot_a, Script_typed_ir.Mutez_key annot_b) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy annot_a annot_b)
(fun annot => Script_typed_ir.Mutez_key annot)
| (Script_typed_ir.Bool_key annot_a, Script_typed_ir.Bool_key annot_b) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy annot_a annot_b)
(fun annot => Script_typed_ir.Bool_key annot)
| (Script_typed_ir.Key_hash_key annot_a, Script_typed_ir.Key_hash_key annot_b)
=>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy annot_a annot_b)
(fun annot => Script_typed_ir.Key_hash_key annot)
|
(Script_typed_ir.Timestamp_key annot_a,
Script_typed_ir.Timestamp_key annot_b) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy annot_a annot_b)
(fun annot => Script_typed_ir.Timestamp_key annot)
| (Script_typed_ir.Address_key annot_a, Script_typed_ir.Address_key annot_b)
=>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy annot_a annot_b)
(fun annot => Script_typed_ir.Address_key annot)
| (_, _) =>
(* ❌ Assert instruction is not handled. *)
assert false
end.
Definition merge_types {b : Set} (legacy : bool)
: Alpha_context.context -> Alpha_context.Script.location ->
Script_typed_ir.ty b -> Script_typed_ir.ty b ->
Error_monad.tzresult (Script_typed_ir.ty b * Alpha_context.context) :=
let fix help {a : Set}
(ctxt : Alpha_context.context) (ty1 : Script_typed_ir.ty a)
(ty2 : Script_typed_ir.ty a) {struct ctxt}
: Error_monad.tzresult (Script_typed_ir.ty a * Alpha_context.context) :=
match (ty1, ty2) with
| (Script_typed_ir.Unit_t tn1, Script_typed_ir.Unit_t tn2) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname => ((Script_typed_ir.Unit_t tname), ctxt))
| (Script_typed_ir.Int_t tn1, Script_typed_ir.Int_t tn2) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname => ((Script_typed_ir.Int_t tname), ctxt))
| (Script_typed_ir.Nat_t tn1, Script_typed_ir.Nat_t tn2) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname => ((Script_typed_ir.Nat_t tname), ctxt))
| (Script_typed_ir.Key_t tn1, Script_typed_ir.Key_t tn2) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname => ((Script_typed_ir.Key_t tname), ctxt))
| (Script_typed_ir.Key_hash_t tn1, Script_typed_ir.Key_hash_t tn2) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname => ((Script_typed_ir.Key_hash_t tname), ctxt))
| (Script_typed_ir.String_t tn1, Script_typed_ir.String_t tn2) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname => ((Script_typed_ir.String_t tname), ctxt))
| (Script_typed_ir.Bytes_t tn1, Script_typed_ir.Bytes_t tn2) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname => ((Script_typed_ir.Bytes_t tname), ctxt))
| (Script_typed_ir.Signature_t tn1, Script_typed_ir.Signature_t tn2) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname => ((Script_typed_ir.Signature_t tname), ctxt))
| (Script_typed_ir.Mutez_t tn1, Script_typed_ir.Mutez_t tn2) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname => ((Script_typed_ir.Mutez_t tname), ctxt))
| (Script_typed_ir.Timestamp_t tn1, Script_typed_ir.Timestamp_t tn2) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname => ((Script_typed_ir.Timestamp_t tname), ctxt))
| (Script_typed_ir.Address_t tn1, Script_typed_ir.Address_t tn2) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname => ((Script_typed_ir.Address_t tname), ctxt))
| (Script_typed_ir.Bool_t tn1, Script_typed_ir.Bool_t tn2) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname => ((Script_typed_ir.Bool_t tname), ctxt))
| (Script_typed_ir.Chain_id_t tn1, Script_typed_ir.Chain_id_t tn2) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname => ((Script_typed_ir.Chain_id_t tname), ctxt))
| (Script_typed_ir.Operation_t tn1, Script_typed_ir.Operation_t tn2) =>
Error_monad.op_gtpipequestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname => ((Script_typed_ir.Operation_t tname), ctxt))
|
(Script_typed_ir.Map_t tal tar tn1 has_big_map,
Script_typed_ir.Map_t tbl tbr tn2 _) =>
Error_monad.op_gtgtquestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname =>
Error_monad.op_gtgtquestion (help ctxt tar tbr)
(fun function_parameter =>
let '(value, ctxt) := function_parameter in
Error_monad.op_gtgtquestion (ty_eq ctxt tar value)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtpipequestion
(merge_comparable_types legacy tal tbl)
(fun tk =>
((Script_typed_ir.Map_t tk value tname has_big_map), ctxt)))))
|
(Script_typed_ir.Big_map_t tal tar tn1,
Script_typed_ir.Big_map_t tbl tbr tn2) =>
Error_monad.op_gtgtquestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname =>
Error_monad.op_gtgtquestion (help ctxt tar tbr)
(fun function_parameter =>
let '(value, ctxt) := function_parameter in
Error_monad.op_gtgtquestion (ty_eq ctxt tar value)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtpipequestion
(merge_comparable_types legacy tal tbl)
(fun tk =>
((Script_typed_ir.Big_map_t tk value tname), ctxt)))))
| (Script_typed_ir.Set_t ea tn1, Script_typed_ir.Set_t eb tn2) =>
Error_monad.op_gtgtquestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname =>
Error_monad.op_gtpipequestion (merge_comparable_types legacy ea eb)
(fun e => ((Script_typed_ir.Set_t e tname), ctxt)))
|
(Script_typed_ir.Pair_t (tal, l_field1, l_var1) (tar, r_field1, r_var1)
tn1 has_big_map,
Script_typed_ir.Pair_t (tbl, l_field2, l_var2) (tbr, r_field2, r_var2)
tn2 _) =>
Error_monad.op_gtgtquestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname =>
Error_monad.op_gtgtquestion
(Script_ir_annot.merge_field_annot legacy l_field1 l_field2)
(fun l_field =>
Error_monad.op_gtgtquestion
(Script_ir_annot.merge_field_annot legacy r_field1 r_field2)
(fun r_field =>
let l_var := Script_ir_annot.merge_var_annot l_var1 l_var2 in
let r_var := Script_ir_annot.merge_var_annot r_var1 r_var2 in
Error_monad.op_gtgtquestion (help ctxt tal tbl)
(fun function_parameter =>
let '(left_ty, ctxt) := function_parameter in
Error_monad.op_gtpipequestion (help ctxt tar tbr)
(fun function_parameter =>
let '(right_ty, ctxt) := function_parameter in
((Script_typed_ir.Pair_t (left_ty, l_field, l_var)
(right_ty, r_field, r_var) tname has_big_map), ctxt))))))
|
(Script_typed_ir.Union_t (tal, tal_annot) (tar, tar_annot) tn1 has_big_map,
Script_typed_ir.Union_t (tbl, tbl_annot) (tbr, tbr_annot) tn2 _) =>
Error_monad.op_gtgtquestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname =>
Error_monad.op_gtgtquestion
(Script_ir_annot.merge_field_annot legacy tal_annot tbl_annot)
(fun left_annot =>
Error_monad.op_gtgtquestion
(Script_ir_annot.merge_field_annot legacy tar_annot tbr_annot)
(fun right_annot =>
Error_monad.op_gtgtquestion (help ctxt tal tbl)
(fun function_parameter =>
let '(left_ty, ctxt) := function_parameter in
Error_monad.op_gtpipequestion (help ctxt tar tbr)
(fun function_parameter =>
let '(right_ty, ctxt) := function_parameter in
((Script_typed_ir.Union_t (left_ty, left_annot)
(right_ty, right_annot) tname has_big_map), ctxt))))))
|
(Script_typed_ir.Lambda_t tal tar tn1,
Script_typed_ir.Lambda_t tbl tbr tn2) =>
Error_monad.op_gtgtquestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname =>
Error_monad.op_gtgtquestion (help ctxt tal tbl)
(fun function_parameter =>
let '(left_ty, ctxt) := function_parameter in
Error_monad.op_gtpipequestion (help ctxt tar tbr)
(fun function_parameter =>
let '(right_ty, ctxt) := function_parameter in
((Script_typed_ir.Lambda_t left_ty right_ty tname), ctxt))))
| (Script_typed_ir.Contract_t tal tn1, Script_typed_ir.Contract_t tbl tn2)
=>
Error_monad.op_gtgtquestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname =>
Error_monad.op_gtpipequestion (help ctxt tal tbl)
(fun function_parameter =>
let '(arg_ty, ctxt) := function_parameter in
((Script_typed_ir.Contract_t arg_ty tname), ctxt)))
|
(Script_typed_ir.Option_t tva tn1 has_big_map,
Script_typed_ir.Option_t tvb tn2 _) =>
Error_monad.op_gtgtquestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname =>
Error_monad.op_gtpipequestion (help ctxt tva tvb)
(fun function_parameter =>
let '(ty, ctxt) := function_parameter in
((Script_typed_ir.Option_t ty tname has_big_map), ctxt)))
|
(Script_typed_ir.List_t tva tn1 has_big_map,
Script_typed_ir.List_t tvb tn2 _) =>
Error_monad.op_gtgtquestion
(Script_ir_annot.merge_type_annot legacy tn1 tn2)
(fun tname =>
Error_monad.op_gtpipequestion (help ctxt tva tvb)
(fun function_parameter =>
let '(ty, ctxt) := function_parameter in
((Script_typed_ir.List_t ty tname has_big_map), ctxt)))
| (_, _) =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
fun ctxt =>
fun loc =>
fun ty1 =>
fun ty2 =>
record_inconsistent_type_annotations ctxt loc ty1 ty2
(help ctxt ty1 ty2).
Definition merge_stacks {ta : Set}
(legacy : bool) (loc : Alpha_context.Script.location)
: Alpha_context.context -> Script_typed_ir.stack_ty ta ->
Script_typed_ir.stack_ty ta ->
Error_monad.tzresult (Script_typed_ir.stack_ty ta * Alpha_context.context) :=
let fix help {a : Set}
(ctxt : Alpha_context.context) (stack1 : Script_typed_ir.stack_ty a)
(stack2 : Script_typed_ir.stack_ty a) {struct ctxt}
: Error_monad.tzresult (Script_typed_ir.stack_ty a * Alpha_context.context) :=
match (stack1, stack2) with
| (Script_typed_ir.Empty_t, Script_typed_ir.Empty_t) =>
Error_monad.ok (Script_typed_ir.Empty_t, ctxt)
|
(Script_typed_ir.Item_t ty1 rest1 annot1,
Script_typed_ir.Item_t ty2 rest2 annot2) =>
let annot := Script_ir_annot.merge_var_annot annot1 annot2 in
Error_monad.op_gtgtquestion (merge_types legacy ctxt loc ty1 ty2)
(fun function_parameter =>
let '(ty, ctxt) := function_parameter in
Error_monad.op_gtpipequestion (help ctxt rest1 rest2)
(fun function_parameter =>
let '(rest, ctxt) := function_parameter in
((Script_typed_ir.Item_t ty rest annot), ctxt)))
end in
help.
Definition has_big_map {t : Set} (function_parameter : Script_typed_ir.ty t)
: bool :=
match function_parameter with
| Script_typed_ir.Unit_t _ => false
| Script_typed_ir.Int_t _ => false
| Script_typed_ir.Nat_t _ => false
| Script_typed_ir.Signature_t _ => false
| Script_typed_ir.String_t _ => false
| Script_typed_ir.Bytes_t _ => false
| Script_typed_ir.Mutez_t _ => false
| Script_typed_ir.Key_hash_t _ => false
| Script_typed_ir.Key_t _ => false
| Script_typed_ir.Timestamp_t _ => false
| Script_typed_ir.Address_t _ => false
| Script_typed_ir.Bool_t _ => false
| Script_typed_ir.Lambda_t _ _ _ => false
| Script_typed_ir.Set_t _ _ => false
| Script_typed_ir.Big_map_t _ _ _ => true
| Script_typed_ir.Contract_t _ _ => false
| Script_typed_ir.Operation_t _ => false
| Script_typed_ir.Chain_id_t _ => false
| Script_typed_ir.Pair_t _ _ _ has_big_map => has_big_map
| Script_typed_ir.Union_t _ _ _ has_big_map => has_big_map
| Script_typed_ir.Option_t _ _ has_big_map => has_big_map
| Script_typed_ir.List_t _ _ has_big_map => has_big_map
| Script_typed_ir.Map_t _ _ _ has_big_map => has_big_map
end.
Module judgement.
Module Failed.
Record record {descr : Set} := {
descr : descr }.
Arguments record : clear implicits.
End Failed.
Definition Failed := Failed.record.
End judgement.
Reserved Notation "'judgement".
Inductive judgement_gadt : Set :=
| Typed : forall {aft bef : Set},
Script_typed_ir.descr bef aft -> judgement_gadt
| Failed : forall {aft bef : Set},
judgement.Failed
((Script_typed_ir.stack_ty aft -> Script_typed_ir.descr bef aft) * aft) ->
judgement_gadt
where "'judgement" := (fun (bef : Set) => judgement_gadt).
Definition judgement := 'judgement.
Module branch.
Record record {t f b : Set} := {
branch :
(Script_typed_ir.descr t r -> Script_typed_ir.descr f r ->
Script_typed_ir.descr b r) * r }.
Arguments record : clear implicits.
Definition with_branch {t_type f_type b_type : Set}
(r : record t_type f_type b_type) branch : record t_type f_type b_type :=
{| branch := branch |}.
End branch.
Definition branch := branch.record.
Definition merge_branches {a b bef : Set}
(legacy : bool) (ctxt : Alpha_context.context) (loc : Z) (btr : judgement a)
(bfr : judgement b) (function_parameter : branch a b bef)
: Lwt.t (Error_monad.tzresult (judgement bef * Alpha_context.context)) :=
let '{| branch.branch := branch |} := function_parameter in
match (btr, bfr) with
|
(Typed ({| Script_typed_ir.descr.aft := aftbt |} as dbt),
Typed ({| Script_typed_ir.descr.aft := aftbf |} as dbf)) =>
let unmatched_branches (function_parameter : unit)
: Lwt.t (Error_monad.tzresult Error_monad.__error) :=
let '_ := function_parameter in
Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt aftbt)
(fun function_parameter =>
let '(aftbt, ctxt) := function_parameter in
Error_monad.op_gtgtpipequestion (serialize_stack_for_error ctxt aftbf)
(fun function_parameter =>
let '(aftbf, _ctxt) := function_parameter in
extensible_type_value)) in
Error_monad.trace_eval unmatched_branches
(Error_monad.op_gtgteqquestion
(Lwt.__return (stack_ty_eq ctxt 1 aftbt aftbf))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return (merge_stacks legacy loc ctxt aftbt aftbf))
(fun function_parameter =>
let '(merged_stack, ctxt) := function_parameter in
Error_monad.__return
((Typed
(branch (Script_typed_ir.descr.with_aft dbt merged_stack)
(Script_typed_ir.descr.with_aft dbf merged_stack))), ctxt))))
|
(Failed {| judgement.Failed.descr := descrt |},
Failed {| judgement.Failed.descr := descrf |}) =>
let __descr_value {D : Set} (ret : Script_typed_ir.stack_ty D)
: Script_typed_ir.descr bef D :=
branch (descrt ret) (descrf ret) in
Error_monad.__return
((Failed {| judgement.Failed.descr := __descr_value |}), ctxt)
| (Typed dbt, Failed {| judgement.Failed.descr := descrf |}) =>
Error_monad.__return
((Typed (branch dbt (descrf (Script_typed_ir.descr.aft dbt)))), ctxt)
| (Failed {| judgement.Failed.descr := descrt |}, Typed dbf) =>
Error_monad.__return
((Typed (branch (descrt (Script_typed_ir.descr.aft dbf)) dbf)), ctxt)
end.
Fixpoint parse_comparable_ty
(ctxt : Alpha_context.context) (ty : Alpha_context.Script.node) {struct ctxt}
: Error_monad.tzresult (ex_comparable_ty * Alpha_context.context) :=
Error_monad.op_gtgtquestion
(Alpha_context.Gas.consume ctxt Typecheck_costs.cycle)
(fun ctxt =>
Error_monad.op_gtgtquestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
match ty with
| Micheline.Prim loc Alpha_context.Script.T_int [] annot =>
Error_monad.op_gtpipequestion
(Script_ir_annot.parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty (Script_typed_ir.Int_key tname)), ctxt))
| Micheline.Prim loc Alpha_context.Script.T_nat [] annot =>
Error_monad.op_gtpipequestion
(Script_ir_annot.parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty (Script_typed_ir.Nat_key tname)), ctxt))
| Micheline.Prim loc Alpha_context.Script.T_string [] annot =>
Error_monad.op_gtpipequestion
(Script_ir_annot.parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty (Script_typed_ir.String_key tname)), ctxt))
| Micheline.Prim loc Alpha_context.Script.T_bytes [] annot =>
Error_monad.op_gtpipequestion
(Script_ir_annot.parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty (Script_typed_ir.Bytes_key tname)), ctxt))
| Micheline.Prim loc Alpha_context.Script.T_mutez [] annot =>
Error_monad.op_gtpipequestion
(Script_ir_annot.parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty (Script_typed_ir.Mutez_key tname)), ctxt))
| Micheline.Prim loc Alpha_context.Script.T_bool [] annot =>
Error_monad.op_gtpipequestion
(Script_ir_annot.parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty (Script_typed_ir.Bool_key tname)), ctxt))
| Micheline.Prim loc Alpha_context.Script.T_key_hash [] annot =>
Error_monad.op_gtpipequestion
(Script_ir_annot.parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty (Script_typed_ir.Key_hash_key tname)), ctxt))
| Micheline.Prim loc Alpha_context.Script.T_timestamp [] annot =>
Error_monad.op_gtpipequestion
(Script_ir_annot.parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty (Script_typed_ir.Timestamp_key tname)), ctxt))
| Micheline.Prim loc Alpha_context.Script.T_address [] annot =>
Error_monad.op_gtpipequestion
(Script_ir_annot.parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty (Script_typed_ir.Address_key tname)), ctxt))
|
Micheline.Prim loc
((Alpha_context.Script.T_int | Alpha_context.Script.T_nat |
Alpha_context.Script.T_string | Alpha_context.Script.T_mutez |
Alpha_context.Script.T_bool | Alpha_context.Script.T_key |
Alpha_context.Script.T_address | Alpha_context.Script.T_timestamp)
as prim) l _ => Error_monad.__error_value extensible_type_value
|
Micheline.Prim loc
(Alpha_context.Script.T_pair | Alpha_context.Script.T_or |
Alpha_context.Script.T_set | Alpha_context.Script.T_map |
Alpha_context.Script.T_list | Alpha_context.Script.T_option |
Alpha_context.Script.T_lambda | Alpha_context.Script.T_unit |
Alpha_context.Script.T_signature | Alpha_context.Script.T_contract)
_ _ => Error_monad.__error_value extensible_type_value
| expr =>
Pervasives.op_atat Error_monad.__error_value
(unexpected expr [] Script_tc_errors.Type_namespace
[
Alpha_context.Script.T_int;
Alpha_context.Script.T_nat;
Alpha_context.Script.T_string;
Alpha_context.Script.T_mutez;
Alpha_context.Script.T_bool;
Alpha_context.Script.T_key;
Alpha_context.Script.T_key_hash;
Alpha_context.Script.T_timestamp
])
end))
with parse_packable_ty (ctxt : Alpha_context.context) (legacy : bool)
{struct ctxt}
: Alpha_context.Script.node ->
Error_monad.tzresult (ex_ty * Alpha_context.context) :=
parse_ty ctxt legacy false false legacy
with parse_parameter_ty (ctxt : Alpha_context.context) (legacy : bool)
{struct ctxt}
: Alpha_context.Script.node ->
Error_monad.tzresult (ex_ty * Alpha_context.context) :=
parse_ty ctxt legacy true false true
with parse_any_ty (ctxt : Alpha_context.context) (legacy : bool) {struct ctxt}
: Alpha_context.Script.node ->
Error_monad.tzresult (ex_ty * Alpha_context.context) :=
parse_ty ctxt legacy true true true
with parse_ty
(ctxt : Alpha_context.context) (legacy : bool) (allow_big_map : bool)
(allow_operation : bool) (allow_contract : bool)
(node : Alpha_context.Script.node) {struct ctxt}
: Error_monad.tzresult (ex_ty * Alpha_context.context) :=
Error_monad.op_gtgtquestion
(Alpha_context.Gas.consume ctxt Typecheck_costs.cycle)
(fun ctxt =>
match
(node,
match node with
| Micheline.Prim loc Alpha_context.Script.T_big_map args annot =>
allow_big_map
| _ => false
end) with
| (Micheline.Prim loc Alpha_context.Script.T_unit [] annot, _) =>
Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt => ((Ex_ty (Script_typed_ir.Unit_t ty_name)), ctxt)))
| (Micheline.Prim loc Alpha_context.Script.T_int [] annot, _) =>
Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt => ((Ex_ty (Script_typed_ir.Int_t ty_name)), ctxt)))
| (Micheline.Prim loc Alpha_context.Script.T_nat [] annot, _) =>
Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt => ((Ex_ty (Script_typed_ir.Nat_t ty_name)), ctxt)))
| (Micheline.Prim loc Alpha_context.Script.T_string [] annot, _) =>
Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt => ((Ex_ty (Script_typed_ir.String_t ty_name)), ctxt)))
| (Micheline.Prim loc Alpha_context.Script.T_bytes [] annot, _) =>
Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt => ((Ex_ty (Script_typed_ir.Bytes_t ty_name)), ctxt)))
| (Micheline.Prim loc Alpha_context.Script.T_mutez [] annot, _) =>
Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt => ((Ex_ty (Script_typed_ir.Mutez_t ty_name)), ctxt)))
| (Micheline.Prim loc Alpha_context.Script.T_bool [] annot, _) =>
Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt => ((Ex_ty (Script_typed_ir.Bool_t ty_name)), ctxt)))
| (Micheline.Prim loc Alpha_context.Script.T_key [] annot, _) =>
Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt => ((Ex_ty (Script_typed_ir.Key_t ty_name)), ctxt)))
| (Micheline.Prim loc Alpha_context.Script.T_key_hash [] annot, _) =>
Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt => ((Ex_ty (Script_typed_ir.Key_hash_t ty_name)), ctxt)))
| (Micheline.Prim loc Alpha_context.Script.T_timestamp [] annot, _) =>
Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt => ((Ex_ty (Script_typed_ir.Timestamp_t ty_name)), ctxt)))
| (Micheline.Prim loc Alpha_context.Script.T_address [] annot, _) =>
Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt => ((Ex_ty (Script_typed_ir.Address_t ty_name)), ctxt)))
| (Micheline.Prim loc Alpha_context.Script.T_signature [] annot, _) =>
Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt => ((Ex_ty (Script_typed_ir.Signature_t ty_name)), ctxt)))
| (Micheline.Prim loc Alpha_context.Script.T_operation [] annot, _) =>
if allow_operation then
Error_monad.op_gtgtquestion
(Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
((Ex_ty (Script_typed_ir.Operation_t ty_name)), ctxt)))
else
Error_monad.__error_value extensible_type_value
| (Micheline.Prim loc Alpha_context.Script.T_chain_id [] annot, _) =>
Error_monad.op_gtgtquestion (Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt => ((Ex_ty (Script_typed_ir.Chain_id_t ty_name)), ctxt)))
|
(Micheline.Prim loc Alpha_context.Script.T_contract (cons utl []) annot,
_) =>
if allow_contract then
Error_monad.op_gtgtquestion (parse_parameter_ty ctxt legacy utl)
(fun function_parameter =>
let '(Ex_ty tl, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 1))
(fun ctxt =>
((Ex_ty (Script_typed_ir.Contract_t tl ty_name)), ctxt))))
else
Error_monad.__error_value extensible_type_value
|
(Micheline.Prim loc Alpha_context.Script.T_pair (cons utl (cons utr []))
annot, _) =>
Error_monad.op_gtgtquestion (Script_ir_annot.extract_field_annot utl)
(fun function_parameter =>
let '(utl, left_field) := function_parameter in
Error_monad.op_gtgtquestion
(Script_ir_annot.extract_field_annot utr)
(fun function_parameter =>
let '(utr, right_field) := function_parameter in
Error_monad.op_gtgtquestion
(parse_ty ctxt legacy allow_big_map allow_operation
allow_contract utl)
(fun function_parameter =>
let '(Ex_ty tl, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(parse_ty ctxt legacy allow_big_map allow_operation
allow_contract utr)
(fun function_parameter =>
let '(Ex_ty tr, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt
(Typecheck_costs.type_ 2))
(fun ctxt =>
((Ex_ty
(Script_typed_ir.Pair_t (tl, left_field, None)
(tr, right_field, None) ty_name
(Pervasives.op_pipepipe (has_big_map tl)
(has_big_map tr)))), ctxt)))))))
|
(Micheline.Prim loc Alpha_context.Script.T_or (cons utl (cons utr []))
annot, _) =>
Error_monad.op_gtgtquestion (Script_ir_annot.extract_field_annot utl)
(fun function_parameter =>
let '(utl, left_constr) := function_parameter in
Error_monad.op_gtgtquestion
(Script_ir_annot.extract_field_annot utr)
(fun function_parameter =>
let '(utr, right_constr) := function_parameter in
Error_monad.op_gtgtquestion
(parse_ty ctxt legacy allow_big_map allow_operation
allow_contract utl)
(fun function_parameter =>
let '(Ex_ty tl, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(parse_ty ctxt legacy allow_big_map allow_operation
allow_contract utr)
(fun function_parameter =>
let '(Ex_ty tr, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt
(Typecheck_costs.type_ 2))
(fun ctxt =>
((Ex_ty
(Script_typed_ir.Union_t (tl, left_constr)
(tr, right_constr) ty_name
(Pervasives.op_pipepipe (has_big_map tl)
(has_big_map tr)))), ctxt)))))))
|
(Micheline.Prim loc Alpha_context.Script.T_lambda
(cons uta (cons utr [])) annot, _) =>
Error_monad.op_gtgtquestion (parse_any_ty ctxt legacy uta)
(fun function_parameter =>
let '(Ex_ty ta, ctxt) := function_parameter in
Error_monad.op_gtgtquestion (parse_any_ty ctxt legacy utr)
(fun function_parameter =>
let '(Ex_ty tr, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 2))
(fun ctxt =>
((Ex_ty (Script_typed_ir.Lambda_t ta tr ty_name)), ctxt)))))
| (Micheline.Prim loc Alpha_context.Script.T_option (cons ut []) annot, _)
=>
Error_monad.op_gtgtquestion
(if legacy then
Error_monad.op_gtgtquestion (Script_ir_annot.extract_field_annot ut)
(fun function_parameter =>
let '(ut, _some_constr) := function_parameter in
Error_monad.op_gtgtquestion
(Script_ir_annot.parse_composed_type_annot loc annot)
(fun function_parameter =>
let '(ty_name, _none_constr, _) := function_parameter in
Error_monad.ok (ut, ty_name)))
else
Error_monad.op_gtgtquestion
(Script_ir_annot.parse_type_annot loc annot)
(fun ty_name => Error_monad.ok (ut, ty_name)))
(fun function_parameter =>
let '(ut, ty_name) := function_parameter in
Error_monad.op_gtgtquestion
(parse_ty ctxt legacy allow_big_map allow_operation allow_contract
ut)
(fun function_parameter =>
let '(Ex_ty __t_value, ctxt) := function_parameter in
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 2))
(fun ctxt =>
((Ex_ty
(Script_typed_ir.Option_t __t_value ty_name
(has_big_map __t_value))), ctxt))))
| (Micheline.Prim loc Alpha_context.Script.T_list (cons ut []) annot, _)
=>
Error_monad.op_gtgtquestion
(parse_ty ctxt legacy allow_big_map allow_operation allow_contract ut)
(fun function_parameter =>
let '(Ex_ty __t_value, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 1))
(fun ctxt =>
((Ex_ty
(Script_typed_ir.List_t __t_value ty_name
(has_big_map __t_value))), ctxt))))
| (Micheline.Prim loc Alpha_context.Script.T_set (cons ut []) annot, _) =>
Error_monad.op_gtgtquestion (parse_comparable_ty ctxt ut)
(fun function_parameter =>
let '(Ex_comparable_ty __t_value, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 1))
(fun ctxt =>
((Ex_ty (Script_typed_ir.Set_t __t_value ty_name)), ctxt))))
|
(Micheline.Prim loc Alpha_context.Script.T_map (cons uta (cons utr []))
annot, _) =>
Error_monad.op_gtgtquestion (parse_comparable_ty ctxt uta)
(fun function_parameter =>
let '(Ex_comparable_ty ta, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(parse_ty ctxt legacy allow_big_map allow_operation allow_contract
utr)
(fun function_parameter =>
let '(Ex_ty tr, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(Script_ir_annot.parse_type_annot loc annot)
(fun ty_name =>
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 2))
(fun ctxt =>
((Ex_ty
(Script_typed_ir.Map_t ta tr ty_name (has_big_map tr))),
ctxt)))))
| (Micheline.Prim loc Alpha_context.Script.T_big_map args annot, true) =>
Error_monad.op_gtgtquestion
(parse_big_map_ty ctxt legacy loc args annot)
(fun function_parameter =>
let '(big_map_ty, ctxt) := function_parameter in
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt (Typecheck_costs.type_ 2))
(fun ctxt => (big_map_ty, ctxt)))
| (Micheline.Prim loc Alpha_context.Script.T_big_map _ _, _) =>
Error_monad.__error_value extensible_type_value
|
(Micheline.Prim loc
((Alpha_context.Script.T_unit | Alpha_context.Script.T_signature |
Alpha_context.Script.T_int | Alpha_context.Script.T_nat |
Alpha_context.Script.T_string | Alpha_context.Script.T_bytes |
Alpha_context.Script.T_mutez | Alpha_context.Script.T_bool |
Alpha_context.Script.T_key | Alpha_context.Script.T_key_hash |
Alpha_context.Script.T_timestamp | Alpha_context.Script.T_address) as
prim) l _, _) => Error_monad.__error_value extensible_type_value
|
(Micheline.Prim loc
((Alpha_context.Script.T_set | Alpha_context.Script.T_list |
Alpha_context.Script.T_option | Alpha_context.Script.T_contract) as
prim) l _, _) => Error_monad.__error_value extensible_type_value
|
(Micheline.Prim loc
((Alpha_context.Script.T_pair | Alpha_context.Script.T_or |
Alpha_context.Script.T_map | Alpha_context.Script.T_lambda) as prim) l
_, _) => Error_monad.__error_value extensible_type_value
| (expr, _) =>
Pervasives.op_atat Error_monad.__error_value
(unexpected expr [] Script_tc_errors.Type_namespace
[
Alpha_context.Script.T_pair;
Alpha_context.Script.T_or;
Alpha_context.Script.T_set;
Alpha_context.Script.T_map;
Alpha_context.Script.T_list;
Alpha_context.Script.T_option;
Alpha_context.Script.T_lambda;
Alpha_context.Script.T_unit;
Alpha_context.Script.T_signature;
Alpha_context.Script.T_contract;
Alpha_context.Script.T_int;
Alpha_context.Script.T_nat;
Alpha_context.Script.T_operation;
Alpha_context.Script.T_string;
Alpha_context.Script.T_bytes;
Alpha_context.Script.T_mutez;
Alpha_context.Script.T_bool;
Alpha_context.Script.T_key;
Alpha_context.Script.T_key_hash;
Alpha_context.Script.T_timestamp;
Alpha_context.Script.T_chain_id
])
end)
with parse_big_map_ty
(ctxt : Alpha_context.context) (legacy : bool)
(big_map_loc : Alpha_context.Script.location)
(args :
list
(Micheline.node Alpha_context.Script.location Alpha_context.Script.prim))
(map_annot : Micheline.annot) {struct ctxt}
: Error_monad.tzresult (ex_ty * Alpha_context.context) :=
Error_monad.op_gtgtquestion
(Alpha_context.Gas.consume ctxt Typecheck_costs.cycle)
(fun ctxt =>
match args with
| cons key_ty (cons value_ty []) =>
Error_monad.op_gtgtquestion (parse_comparable_ty ctxt key_ty)
(fun function_parameter =>
let '(Ex_comparable_ty key_ty, ctxt) := function_parameter in
Error_monad.op_gtgtquestion (parse_packable_ty ctxt legacy value_ty)
(fun function_parameter =>
let '(Ex_ty value_ty, ctxt) := function_parameter in
Error_monad.op_gtpipequestion
(Script_ir_annot.parse_type_annot big_map_loc map_annot)
(fun map_name =>
let big_map_ty :=
Script_typed_ir.Big_map_t key_ty value_ty map_name in
((Ex_ty big_map_ty), ctxt))))
| args =>
Pervasives.op_atat Error_monad.__error_value extensible_type_value
end)
with parse_storage_ty
(ctxt : Alpha_context.context) (legacy : bool)
(node : Alpha_context.Script.node) {struct ctxt}
: Error_monad.tzresult (ex_ty * Alpha_context.context) :=
match
(node,
match node with
|
Micheline.Prim loc Alpha_context.Script.T_pair
(cons
(Micheline.Prim big_map_loc Alpha_context.Script.T_big_map args
map_annot) (cons remaining_storage [])) storage_annot => legacy
| _ => false
end) with
|
(Micheline.Prim loc Alpha_context.Script.T_pair
(cons
(Micheline.Prim big_map_loc Alpha_context.Script.T_big_map args
map_annot) (cons remaining_storage [])) storage_annot, true) =>
match
(storage_annot,
match storage_annot with
| cons single [] =>
Pervasives.op_andand
((|Compare.Int|).(Compare.S.op_gt) (String.length single) 0)
((|Compare.Char|).(Compare.S.op_eq) (String.get single 0) "%" % char)
| _ => false
end) with
| ([], _) => parse_ty ctxt legacy true false legacy node
| (cons single [], true) => parse_ty ctxt legacy true false legacy node
| (_, _) =>
Error_monad.op_gtgtquestion
(Alpha_context.Gas.consume ctxt Typecheck_costs.cycle)
(fun ctxt =>
Error_monad.op_gtgtquestion
(parse_big_map_ty ctxt legacy big_map_loc args map_annot)
(fun function_parameter =>
let '(Ex_ty big_map_ty, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(parse_ty ctxt legacy true false legacy remaining_storage)
(fun function_parameter =>
let '(Ex_ty remaining_storage, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(Script_ir_annot.parse_composed_type_annot loc storage_annot)
(fun function_parameter =>
let '(ty_name, map_field, storage_field) :=
function_parameter in
Error_monad.op_gtpipequestion
(Alpha_context.Gas.consume ctxt
(Typecheck_costs.type_ 5))
(fun ctxt =>
((Ex_ty
(Script_typed_ir.Pair_t
(big_map_ty, map_field, None)
(remaining_storage, storage_field, None) ty_name
true)), ctxt))))))
end
| (_, _) => parse_ty ctxt legacy true false legacy node
end.
Definition check_packable {A : Set}
(legacy : bool) (loc : Alpha_context.Script.location)
(root : Script_typed_ir.ty A) : Error_monad.tzresult unit :=
let fix check {t : Set} (function_parameter : Script_typed_ir.ty t)
{struct function_parameter} : Error_monad.tzresult unit :=
match
(function_parameter,
match function_parameter with
| Script_typed_ir.Contract_t _ _ => legacy
| _ => false
end) with
| (Script_typed_ir.Big_map_t _ _ _, _) =>
Error_monad.__error_value extensible_type_value
| (Script_typed_ir.Operation_t _, _) =>
Error_monad.__error_value extensible_type_value
| (Script_typed_ir.Unit_t _, _) => Error_monad.ok tt
| (Script_typed_ir.Int_t _, _) => Error_monad.ok tt
| (Script_typed_ir.Nat_t _, _) => Error_monad.ok tt
| (Script_typed_ir.Signature_t _, _) => Error_monad.ok tt
| (Script_typed_ir.String_t _, _) => Error_monad.ok tt
| (Script_typed_ir.Bytes_t _, _) => Error_monad.ok tt
| (Script_typed_ir.Mutez_t _, _) => Error_monad.ok tt
| (Script_typed_ir.Key_hash_t _, _) => Error_monad.ok tt
| (Script_typed_ir.Key_t _, _) => Error_monad.ok tt
| (Script_typed_ir.Timestamp_t _, _) => Error_monad.ok tt
| (Script_typed_ir.Address_t _, _) => Error_monad.ok tt
| (Script_typed_ir.Bool_t _, _) => Error_monad.ok tt
| (Script_typed_ir.Chain_id_t _, _) => Error_monad.ok tt
| (Script_typed_ir.Pair_t (l_ty, _, _) (r_ty, _, _) _ _, _) =>
Error_monad.op_gtgtquestion (check l_ty)
(fun function_parameter =>
let '_ := function_parameter in
check r_ty)
| (Script_typed_ir.Union_t (l_ty, _) (r_ty, _) _ _, _) =>
Error_monad.op_gtgtquestion (check l_ty)
(fun function_parameter =>
let '_ := function_parameter in
check r_ty)
| (Script_typed_ir.Option_t v_ty _ _, _) => check v_ty
| (Script_typed_ir.List_t elt_ty _ _, _) => check elt_ty
| (Script_typed_ir.Set_t _ _, _) => Error_monad.ok tt
| (Script_typed_ir.Map_t _ elt_ty _ _, _) => check elt_ty
| (Script_typed_ir.Lambda_t _l_ty _r_ty _, _) => Error_monad.ok tt
| (Script_typed_ir.Contract_t _ _, true) => Error_monad.ok tt
| (Script_typed_ir.Contract_t _ _, _) =>
Error_monad.__error_value extensible_type_value
end in
check root.
Reserved Notation "'ex_script".
Inductive ex_script_gadt : Set :=
| Ex_script : forall {a c : Set}, Script_typed_ir.script a c -> ex_script_gadt
where "'ex_script" := (ex_script_gadt).
Definition ex_script := 'ex_script.
Reserved Notation "'dig_proof_argument".
Inductive dig_proof_argument_gadt : Set :=
| Dig_proof_argument : forall {aft bef rest x : Set},
Script_typed_ir.stack_prefix_preservation_witness (x * rest) rest bef aft *
(Script_typed_ir.ty x * option Script_typed_ir.var_annot) *
Script_typed_ir.stack_ty aft -> dig_proof_argument_gadt
where "'dig_proof_argument" := (fun (_ : Set) => dig_proof_argument_gadt).
Definition dig_proof_argument := 'dig_proof_argument.
Reserved Notation "'dug_proof_argument".
Inductive dug_proof_argument_gadt : Set :=
| Dug_proof_argument : forall {aft bef rest x : Set},
Script_typed_ir.stack_prefix_preservation_witness rest (x * rest) bef aft *
unit * Script_typed_ir.stack_ty aft -> dug_proof_argument_gadt
where "'dug_proof_argument" := (fun (_ _ : Set) => dug_proof_argument_gadt).
Definition dug_proof_argument := 'dug_proof_argument.
Reserved Notation "'dipn_proof_argument".
Inductive dipn_proof_argument_gadt : Set :=
| Dipn_proof_argument : forall {aft bef faft fbef : Set},
Script_typed_ir.stack_prefix_preservation_witness fbef faft bef aft *
(Alpha_context.context * Script_typed_ir.descr fbef faft) *
Script_typed_ir.stack_ty aft -> dipn_proof_argument_gadt
where "'dipn_proof_argument" := (fun (_ : Set) => dipn_proof_argument_gadt).
Definition dipn_proof_argument := 'dipn_proof_argument.
Reserved Notation "'dropn_proof_argument".
Inductive dropn_proof_argument_gadt : Set :=
| Dropn_proof_argument : forall {aft bef rest : Set},
Script_typed_ir.stack_prefix_preservation_witness rest rest bef aft *
Script_typed_ir.stack_ty rest * Script_typed_ir.stack_ty aft ->
dropn_proof_argument_gadt
where "'dropn_proof_argument" := (fun (_ : Set) => dropn_proof_argument_gadt).
Definition dropn_proof_argument := 'dropn_proof_argument.
Definition parse_var_annot
(loc : Z) (default : option (option Script_typed_ir.var_annot))
(annot : list string)
: Lwt.t (Error_monad.tzresult (option Script_typed_ir.var_annot)) :=
Lwt.__return (Script_ir_annot.parse_var_annot loc default annot).
Definition parse_entrypoint_annot
(loc : Z) (default : option (option Script_typed_ir.var_annot))
(annot : list string)
: Lwt.t
(Error_monad.tzresult
(option Script_typed_ir.var_annot * option Script_typed_ir.field_annot)) :=
Lwt.__return (Script_ir_annot.parse_entrypoint_annot loc default annot).
Definition parse_constr_annot
(loc : Z) (if_special_first : option (option Script_typed_ir.field_annot))
(if_special_second : option (option Script_typed_ir.field_annot))
(annot : list string)
: Lwt.t
(Error_monad.tzresult
(option Script_typed_ir.var_annot * option Script_typed_ir.type_annot *
option Script_typed_ir.field_annot * option Script_typed_ir.field_annot)) :=
Lwt.__return
(Script_ir_annot.parse_constr_annot loc if_special_first if_special_second
annot).
Definition parse_two_var_annot (loc : Z) (annot : list string)
: Lwt.t
(Error_monad.tzresult
(option Script_typed_ir.var_annot * option Script_typed_ir.var_annot)) :=
Lwt.__return (Script_ir_annot.parse_two_var_annot loc annot).
Definition parse_destr_annot
(loc : Z) (annot : list string)
(default_accessor : option Script_typed_ir.field_annot)
(field_name : option Script_typed_ir.field_annot)
(pair_annot : option Script_typed_ir.var_annot)
(value_annot : option Script_typed_ir.var_annot)
: Lwt.t
(Error_monad.tzresult
(option Script_typed_ir.var_annot * option Script_typed_ir.field_annot)) :=
Lwt.__return
(Script_ir_annot.parse_destr_annot loc annot default_accessor field_name
pair_annot value_annot).
Definition parse_var_type_annot (loc : Z) (annot : list string)
: Lwt.t
(Error_monad.tzresult
(option Script_typed_ir.var_annot * option Script_typed_ir.type_annot)) :=
Lwt.__return (Script_ir_annot.parse_var_type_annot loc annot).
Definition find_entrypoint {A : Set}
(full : Script_typed_ir.ty A)
(root_name : option (|Compare.String|).(Compare.S.t))
(entrypoint : (|Compare.String|).(Compare.S.t))
: Error_monad.tzresult
((Alpha_context.Script.node -> Alpha_context.Script.node) * ex_ty) :=
let fix find_entrypoint {t : Set}
(__t_value : Script_typed_ir.ty t) (entrypoint : string) {struct __t_value}
: (Alpha_context.Script.node -> Alpha_context.Script.node) * ex_ty :=
match __t_value with
| Script_typed_ir.Union_t (tl, al) (tr, ar) _ _ =>
if
match al with
| None => false
| Some (Field_annot l) =>
(|Compare.String|).(Compare.S.op_eq) l entrypoint
end then
((fun e => Micheline.Prim 0 Alpha_context.Script.D_Left [ e ] []),
(Ex_ty tl))
else
if
match ar with
| None => false
| Some (Field_annot r) =>
(|Compare.String|).(Compare.S.op_eq) r entrypoint
end then
((fun e => Micheline.Prim 0 Alpha_context.Script.D_Right [ e ] []),
(Ex_ty tr))
else
(* ❌ Try-with are not handled *)
try
(let '(f, __t_value) := find_entrypoint tl entrypoint in
((fun e => Micheline.Prim 0 Alpha_context.Script.D_Left [ f e ] []),
__t_value))
| _ => Pervasives.raise extensible_type_value
end in
let entrypoint :=
if (|Compare.String|).(Compare.S.op_eq) entrypoint "" then
"default"
else
entrypoint in
if (|Compare.Int|).(Compare.S.op_gt) (String.length entrypoint) 31 then
Error_monad.__error_value extensible_type_value
else
match
(root_name,
match root_name with
| Some root_name =>
(|Compare.String|).(Compare.S.op_eq) entrypoint root_name
| _ => false
end) with
| (Some root_name, true) => Error_monad.ok ((fun e => e), (Ex_ty full))
| (_, _) =>
(* ❌ Try-with are not handled *)
try (Error_monad.ok (find_entrypoint full entrypoint))
end.
Definition find_entrypoint_for_type {A B : Set}
(full : Script_typed_ir.ty A) (expected : Script_typed_ir.ty B)
(root_name : option (|Compare.String|).(Compare.S.t))
(entrypoint : (|Compare.String|).(Compare.S.t)) (ctxt : Alpha_context.context)
: Error_monad.tzresult (Alpha_context.context * string * Script_typed_ir.ty B) :=
match (entrypoint, root_name) with
| ("default", Some "root") =>
match find_entrypoint full root_name entrypoint with
| (Pervasives.Error _) as err => err
| Pervasives.Ok (_, Ex_ty ty) =>
match ty_eq ctxt expected ty with
| Pervasives.Ok (Eq, ctxt) => Error_monad.ok (ctxt, "default", ty)
| Pervasives.Error _ =>
Error_monad.op_gtgtquestion (ty_eq ctxt expected full)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.ok (ctxt, "root", full))
end
end
| _ =>
Error_monad.op_gtgtquestion (find_entrypoint full root_name entrypoint)
(fun function_parameter =>
let '(_, Ex_ty ty) := function_parameter in
Error_monad.op_gtgtquestion (ty_eq ctxt expected ty)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.ok (ctxt, entrypoint, ty)))
end.
Definition Entrypoints :=
__Set.Make
(existT _ _
{|
Compare.COMPARABLE.compare := String.compare
|}).
(* ❌ The definition of exceptions is not handled. *)
(* exception Duplicate *)
(* ❌ The definition of exceptions is not handled. *)
(* exception Too_long *)
Definition well_formed_entrypoints {A : Set}
(full : Script_typed_ir.ty A) (root_name : option (|Entrypoints|).(S.SET.elt))
: Error_monad.tzresult unit :=
let merge {B C : Set}
(path : list B)
(annot : option (* `Field_annot *) (|Entrypoints|).(S.SET.elt))
(ty : Script_typed_ir.ty C) (reachable : bool)
(function_parameter : option (list B) * (|Entrypoints|).(S.SET.t))
: option (list B) * (|Entrypoints|).(S.SET.t) :=
let '(first_unreachable, all) as acc := function_parameter in
match annot with
| None | Some (Field_annot "") =>
if reachable then
acc
else
match ty with
| Script_typed_ir.Union_t _ _ _ _ => acc
| _ =>
match first_unreachable with
| None => ((Some (List.rev path)), all)
| Some _ => acc
end
end
| Some (Field_annot name) =>
if (|Compare.Int|).(Compare.S.op_gt) (String.length name) 31 then
Pervasives.raise extensible_type_value
else
if (|Entrypoints|).(S.SET.mem) name all then
Pervasives.raise extensible_type_value
else
(first_unreachable, ((|Entrypoints|).(S.SET.add) name all))
end in
let fix check {t : Set}
(__t_value : Script_typed_ir.ty t) (path : list Alpha_context.Script.prim)
(reachable : bool)
(acc : option (list Alpha_context.Script.prim) * (|Entrypoints|).(S.SET.t))
{struct __t_value}
: option (list Alpha_context.Script.prim) * (|Entrypoints|).(S.SET.t) :=
match __t_value with
| Script_typed_ir.Union_t (tl, al) (tr, ar) _ _ =>
let acc :=
merge (cons Alpha_context.Script.D_Left path) al tl reachable acc in
let acc :=
merge (cons Alpha_context.Script.D_Right path) ar tr reachable acc in
let acc :=
check tl (cons Alpha_context.Script.D_Left path)
match al with
| Some _ => true
| None => reachable
end acc in
check tr (cons Alpha_context.Script.D_Right path)
match ar with
| Some _ => true
| None => reachable
end acc
| _ => acc
end in
(* ❌ Try-with are not handled *)
try
(let '(init, reachable) :=
match root_name with
| None | Some "" => ((|Entrypoints|).(S.SET.empty), false)
| Some name => (((|Entrypoints|).(S.SET.singleton) name), true)
end in
let '(first_unreachable, all) := check full [] reachable (None, init) in
if Pervasives.not ((|Entrypoints|).(S.SET.mem) "default" all) then
Error_monad.ok tt
else
match first_unreachable with
| None => Error_monad.ok tt
| Some path => Error_monad.__error_value extensible_type_value
end).
Fixpoint parse_data {a : Set}
(type_logger : option type_logger) (ctxt : Alpha_context.context)
(legacy : bool) (ty : Script_typed_ir.ty a)
(script_data : Alpha_context.Script.node) {struct type_logger}
: Lwt.t (Error_monad.tzresult (a * Alpha_context.context)) :=
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
let __error_value (function_parameter : unit)
: Lwt.t (Error_monad.tzresult Error_monad.__error) :=
let '_ := function_parameter in
Error_monad.op_gtgtpipequestion
(Lwt.__return (serialize_ty_for_error ctxt ty))
(fun function_parameter =>
let '(ty, _ctxt) := function_parameter in
extensible_type_value) in
let traced {B : Set} (body : Lwt.t (Error_monad.tzresult B))
: Lwt.t (Error_monad.tzresult B) :=
Error_monad.trace_eval __error_value body in
let parse_items {B C D E : Set}
(type_logger : option type_logger) (loc : Alpha_context.Script.location)
(ctxt : Alpha_context.context)
(expr : Micheline.node B Alpha_context.Script.prim)
(key_type : Script_typed_ir.comparable_ty C)
(value_type : Script_typed_ir.ty D)
(items :
list
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim)) (item_wrapper : D -> E)
: Lwt.t
(Error_monad.tzresult
(Script_typed_ir.map C E * Alpha_context.context)) :=
let length := List.length items in
Error_monad.op_gtgtpipequestion
(Pervasives.op_pipegt
(Error_monad.fold_left_s
(fun function_parameter =>
let '(last_value, map, ctxt) := function_parameter in
fun item =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt
(Typecheck_costs.map_element length)))
(fun ctxt =>
match item with
|
Micheline.Prim _ Alpha_context.Script.D_Elt
(cons k (cons v [])) _ =>
Error_monad.op_gtgteqquestion
(parse_comparable_data type_logger ctxt key_type k)
(fun function_parameter =>
let '(k, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(parse_data type_logger ctxt legacy value_type v)
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
match last_value with
| Some value =>
if
(|Compare.Int|).(Compare.S.op_lteq) 0
(compare_comparable key_type value k)
then
if
(|Compare.Int|).(Compare.S.op_eq) 0
(compare_comparable key_type value k)
then
Error_monad.fail extensible_type_value
else
Error_monad.fail extensible_type_value
else
Error_monad.return_unit
| None => Error_monad.return_unit
end
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.__return
((Some k),
(map_update k (Some (item_wrapper v))
map), ctxt))))
| Micheline.Prim loc Alpha_context.Script.D_Elt l _ =>
Pervasives.op_atat Error_monad.fail
extensible_type_value
| Micheline.Prim loc name _ _ =>
Pervasives.op_atat Error_monad.fail
extensible_type_value
|
Micheline.Int _ _ | Micheline.String _ _ |
Micheline.Bytes _ _ | Micheline.Seq _ _ =>
Error_monad.op_gtgteqquestion (__error_value tt)
Error_monad.fail
end)) (None, (empty_map key_type), ctxt) items) traced)
(fun function_parameter =>
let '(_, items, ctxt) := function_parameter in
(items, ctxt)) in
match (ty, script_data) with
|
(Script_typed_ir.Unit_t _,
Micheline.Prim loc Alpha_context.Script.D_Unit [] annot) =>
Error_monad.op_gtgteqquestion
(if legacy then
Error_monad.__return tt
else
Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgtpipequestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.__unit_value))
(fun ctxt => (tt, ctxt)))
|
(Script_typed_ir.Unit_t _,
Micheline.Prim loc Alpha_context.Script.D_Unit l _) =>
traced (Error_monad.fail extensible_type_value)
| (Script_typed_ir.Unit_t _, expr) =>
traced
(Error_monad.fail
(unexpected expr [] Script_tc_errors.Constant_namespace
[ Alpha_context.Script.D_Unit ]))
|
(Script_typed_ir.Bool_t _,
Micheline.Prim loc Alpha_context.Script.D_True [] annot) =>
Error_monad.op_gtgteqquestion
(if legacy then
Error_monad.__return tt
else
Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgtpipequestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.__bool_value))
(fun ctxt => (true, ctxt)))
|
(Script_typed_ir.Bool_t _,
Micheline.Prim loc Alpha_context.Script.D_False [] annot) =>
Error_monad.op_gtgteqquestion
(if legacy then
Error_monad.__return tt
else
Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgtpipequestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.__bool_value))
(fun ctxt => (false, ctxt)))
|
(Script_typed_ir.Bool_t _,
Micheline.Prim loc
((Alpha_context.Script.D_True | Alpha_context.Script.D_False) as c)
l _) => traced (Error_monad.fail extensible_type_value)
| (Script_typed_ir.Bool_t _, expr) =>
traced
(Error_monad.fail
(unexpected expr [] Script_tc_errors.Constant_namespace
[ Alpha_context.Script.D_True; Alpha_context.Script.D_False ]))
| (Script_typed_ir.String_t _, Micheline.String _ v) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt
(Typecheck_costs.__string_value (String.length v))))
(fun ctxt =>
let fix check_printable_ascii (i : (|Compare.Int|).(Compare.S.t))
{struct i} : bool :=
if (|Compare.Int|).(Compare.S.op_lt) i 0 then
true
else
match String.get v i with
|
"010" % char | " " % char | "!" % char | """" % char |
"#" % char | "$" % char | "%" % char | "&" % char | "'" % char
| "(" % char | ")" % char | "*" % char | "+" % char |
"," % char | "-" % char | "." % char | "/" % char | "0" % char
| "1" % char | "2" % char | "3" % char | "4" % char |
"5" % char | "6" % char | "7" % char | "8" % char | "9" % char
| ":" % char | ";" % char | "<" % char | "=" % char |
">" % char | "?" % char | "@" % char | "A" % char | "B" % char
| "C" % char | "D" % char | "E" % char | "F" % char |
"G" % char | "H" % char | "I" % char | "J" % char | "K" % char
| "L" % char | "M" % char | "N" % char | "O" % char |
"P" % char | "Q" % char | "R" % char | "S" % char | "T" % char
| "U" % char | "V" % char | "W" % char | "X" % char |
"Y" % char | "Z" % char | "[" % char | "\" % char | "]" % char
| "^" % char | "_" % char | "`" % char | "a" % char |
"b" % char | "c" % char | "d" % char | "e" % char | "f" % char
| "g" % char | "h" % char | "i" % char | "j" % char |
"k" % char | "l" % char | "m" % char | "n" % char | "o" % char
| "p" % char | "q" % char | "r" % char | "s" % char |
"t" % char | "u" % char | "v" % char | "w" % char | "x" % char
| "y" % char | "z" % char | "{" % char | "|" % char |
"}" % char | "~" % char =>
check_printable_ascii (Pervasives.op_minus i 1)
| _ => false
end in
if check_printable_ascii (Pervasives.op_minus (String.length v) 1)
then
Error_monad.__return (v, ctxt)
else
Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail)
| (Script_typed_ir.String_t _, expr) =>
traced (Error_monad.fail extensible_type_value)
| (Script_typed_ir.Bytes_t _, Micheline.Bytes _ v) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt
(Typecheck_costs.__string_value (MBytes.length v))))
(fun ctxt => Error_monad.__return (v, ctxt))
| (Script_typed_ir.Bytes_t _, expr) =>
traced (Error_monad.fail extensible_type_value)
| (Script_typed_ir.Int_t _, Micheline.Int _ v) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt (Typecheck_costs.z v)))
(fun ctxt =>
Error_monad.__return ((Alpha_context.Script_int.of_zint v), ctxt))
| (Script_typed_ir.Nat_t _, Micheline.Int _ v) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt (Typecheck_costs.z v)))
(fun ctxt =>
let v := Alpha_context.Script_int.of_zint v in
if
(|Compare.Int|).(Compare.S.op_gteq)
(Alpha_context.Script_int.compare v
Alpha_context.Script_int.zero) 0 then
Error_monad.__return ((Alpha_context.Script_int.abs v), ctxt)
else
Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail)
| (Script_typed_ir.Int_t _, expr) =>
traced (Error_monad.fail extensible_type_value)
| (Script_typed_ir.Nat_t _, expr) =>
traced (Error_monad.fail extensible_type_value)
| (Script_typed_ir.Mutez_t _, Micheline.Int _ v) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Error_monad.op_gtgtquestion
(Alpha_context.Gas.consume ctxt Typecheck_costs.tez)
(fun ctxt =>
Alpha_context.Gas.consume ctxt
Michelson_v1_gas.Cost_of.Legacy.z_to_int64)))
(fun ctxt =>
(* ❌ Try-with are not handled *)
try
match Alpha_context.Tez.of_mutez (Z.to_int64 v) with
| None => Pervasives.raise extensible_type_value
| Some tez => Error_monad.__return (tez, ctxt)
end)
| (Script_typed_ir.Mutez_t _, expr) =>
traced (Error_monad.fail extensible_type_value)
| (Script_typed_ir.Timestamp_t _, Micheline.Int _ v) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt (Typecheck_costs.z v)))
(fun ctxt =>
Error_monad.__return
((Alpha_context.Script_timestamp.of_zint v), ctxt))
| (Script_typed_ir.Timestamp_t _, Micheline.String _ s) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.string_timestamp))
(fun ctxt =>
match Alpha_context.Script_timestamp.of_string s with
| Some v => Error_monad.__return (v, ctxt)
| None =>
Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
end)
| (Script_typed_ir.Timestamp_t _, expr) =>
traced (Error_monad.fail extensible_type_value)
| (Script_typed_ir.Key_t _, Micheline.Bytes _ __bytes_value) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.key))
(fun ctxt =>
match
Data_encoding.Binary.of_bytes
(|Signature.Public_key|).(S.SPublic_key.encoding) __bytes_value
with
| Some k => Error_monad.__return (k, ctxt)
| None =>
Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
end)
| (Script_typed_ir.Key_t _, Micheline.String _ s) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.key))
(fun ctxt =>
match (|Signature.Public_key|).(S.SPublic_key.of_b58check_opt) s
with
| Some k => Error_monad.__return (k, ctxt)
| None =>
Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
end)
| (Script_typed_ir.Key_t _, expr) =>
traced (Error_monad.fail extensible_type_value)
| (Script_typed_ir.Key_hash_t _, Micheline.Bytes _ __bytes_value) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.key_hash))
(fun ctxt =>
match
Data_encoding.Binary.of_bytes
(|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding)
__bytes_value with
| Some k => Error_monad.__return (k, ctxt)
| None =>
Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
end)
| (Script_typed_ir.Key_hash_t _, Micheline.String _ s) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.key_hash))
(fun ctxt =>
match
(|Signature.Public_key_hash|).(S.SPublic_key_hash.of_b58check_opt)
s with
| Some k => Error_monad.__return (k, ctxt)
| None =>
Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
end)
| (Script_typed_ir.Key_hash_t _, expr) =>
traced (Error_monad.fail extensible_type_value)
| (Script_typed_ir.Signature_t _, Micheline.Bytes _ __bytes_value) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.signature))
(fun ctxt =>
match Data_encoding.Binary.of_bytes Signature.encoding __bytes_value
with
| Some k => Error_monad.__return (k, ctxt)
| None =>
Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
end)
| (Script_typed_ir.Signature_t _, Micheline.String _ s) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.signature))
(fun ctxt =>
match Signature.of_b58check_opt s with
| Some s => Error_monad.__return (s, ctxt)
| None =>
Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
end)
| (Script_typed_ir.Signature_t _, expr) =>
traced (Error_monad.fail extensible_type_value)
| (Script_typed_ir.Operation_t _, _) =>
(* ❌ Assert instruction is not handled. *)
assert false
| (Script_typed_ir.Chain_id_t _, Micheline.Bytes _ __bytes_value) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.chain_id))
(fun ctxt =>
match
Data_encoding.Binary.of_bytes (|Chain_id|).(S.HASH.encoding)
__bytes_value with
| Some k => Error_monad.__return (k, ctxt)
| None =>
Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
end)
| (Script_typed_ir.Chain_id_t _, Micheline.String _ s) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.chain_id))
(fun ctxt =>
match (|Chain_id|).(S.HASH.of_b58check_opt) s with
| Some s => Error_monad.__return (s, ctxt)
| None =>
Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
end)
| (Script_typed_ir.Chain_id_t _, expr) =>
traced (Error_monad.fail extensible_type_value)
| (Script_typed_ir.Address_t _, Micheline.Bytes loc __bytes_value) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.contract))
(fun ctxt =>
match
Data_encoding.Binary.of_bytes
(Data_encoding.tup2 Alpha_context.Contract.encoding
Data_encoding.__Variable.__string_value) __bytes_value with
| Some (c, entrypoint) =>
if (|Compare.Int|).(Compare.S.op_gt) (String.length entrypoint) 31
then
Error_monad.fail extensible_type_value
else
Error_monad.op_gtgteqquestion
match entrypoint with
| "" => Error_monad.__return "default"
| "default" => Error_monad.fail extensible_type_value
| name => Error_monad.__return name
end
(fun entrypoint =>
Error_monad.__return ((c, entrypoint), ctxt))
| None =>
Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
end)
| (Script_typed_ir.Address_t _, Micheline.String loc s) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.contract))
(fun ctxt =>
Error_monad.op_gtgteqquestion
match String.index_opt s "%" % char with
| None => Error_monad.__return (s, "default")
| Some pos =>
let len :=
Pervasives.op_minus
(Pervasives.op_minus (String.length s) pos) 1 in
let name := String.sub s (Pervasives.op_plus pos 1) len in
if (|Compare.Int|).(Compare.S.op_gt) len 31 then
Error_monad.fail extensible_type_value
else
match ((String.sub s 0 pos), name) with
| (_, "default") =>
traced (Error_monad.fail extensible_type_value)
| addr_and_name => Error_monad.__return addr_and_name
end
end
(fun function_parameter =>
let '(addr, entrypoint) := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Contract.of_b58check addr))
(fun c => Error_monad.__return ((c, entrypoint), ctxt))))
| (Script_typed_ir.Address_t _, expr) =>
traced (Error_monad.fail extensible_type_value)
| (Script_typed_ir.Contract_t ty _, Micheline.Bytes loc __bytes_value) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.contract))
(fun ctxt =>
match
Data_encoding.Binary.of_bytes
(Data_encoding.tup2 Alpha_context.Contract.encoding
Data_encoding.__Variable.__string_value) __bytes_value with
| Some (c, entrypoint) =>
if (|Compare.Int|).(Compare.S.op_gt) (String.length entrypoint) 31
then
Error_monad.fail extensible_type_value
else
Error_monad.op_gtgteqquestion
match entrypoint with
| "" => Error_monad.__return "default"
| "default" => traced (Error_monad.fail extensible_type_value)
| name => Error_monad.__return name
end
(fun entrypoint =>
Error_monad.op_gtgteqquestion
(traced (parse_contract legacy ctxt loc ty c entrypoint))
(fun function_parameter =>
let '(ctxt, _) := function_parameter in
Error_monad.__return ((ty, (c, entrypoint)), ctxt)))
| None =>
Error_monad.op_gtgteqquestion (__error_value tt) Error_monad.fail
end)
| (Script_typed_ir.Contract_t ty _, Micheline.String loc s) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.contract))
(fun ctxt =>
Error_monad.op_gtgteqquestion
match String.index_opt s "%" % char with
| None => Error_monad.__return (s, "default")
| Some pos =>
let len :=
Pervasives.op_minus
(Pervasives.op_minus (String.length s) pos) 1 in
let name := String.sub s (Pervasives.op_plus pos 1) len in
if (|Compare.Int|).(Compare.S.op_gt) len 31 then
Error_monad.fail extensible_type_value
else
match ((String.sub s 0 pos), name) with
| (_, "default") =>
traced (Error_monad.fail extensible_type_value)
| addr_and_name => Error_monad.__return addr_and_name
end
end
(fun function_parameter =>
let '(addr, entrypoint) := function_parameter in
Error_monad.op_gtgteqquestion
(traced
(Lwt.__return (Alpha_context.Contract.of_b58check addr)))
(fun c =>
Error_monad.op_gtgteqquestion
(parse_contract legacy ctxt loc ty c entrypoint)
(fun function_parameter =>
let '(ctxt, _) := function_parameter in
Error_monad.__return ((ty, (c, entrypoint)), ctxt)))))
| (Script_typed_ir.Contract_t _ _, expr) =>
traced (Error_monad.fail extensible_type_value)
|
(Script_typed_ir.Pair_t (ta, _, _) (tb, _, _) _ _,
Micheline.Prim loc Alpha_context.Script.D_Pair (cons va (cons vb []))
annot) =>
Error_monad.op_gtgteqquestion
(if legacy then
Error_monad.__return tt
else
Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.pair))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat traced
(parse_data type_logger ctxt legacy ta va))
(fun function_parameter =>
let '(va, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(parse_data type_logger ctxt legacy tb vb)
(fun function_parameter =>
let '(vb, ctxt) := function_parameter in
Error_monad.__return ((va, vb), ctxt)))))
|
(Script_typed_ir.Pair_t _ _ _ _,
Micheline.Prim loc Alpha_context.Script.D_Pair l _) =>
Pervasives.op_atat Error_monad.fail extensible_type_value
| (Script_typed_ir.Pair_t _ _ _ _, expr) =>
traced
(Error_monad.fail
(unexpected expr [] Script_tc_errors.Constant_namespace
[ Alpha_context.Script.D_Pair ]))
|
(Script_typed_ir.Union_t (tl, _) _ _ _,
Micheline.Prim loc Alpha_context.Script.D_Left (cons v []) annot) =>
Error_monad.op_gtgteqquestion
(if legacy then
Error_monad.__return tt
else
Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.union))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat traced
(parse_data type_logger ctxt legacy tl v))
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
Error_monad.__return ((Script_typed_ir.L v), ctxt))))
|
(Script_typed_ir.Union_t _ _ _ _,
Micheline.Prim loc Alpha_context.Script.D_Left l _) =>
Pervasives.op_atat Error_monad.fail extensible_type_value
|
(Script_typed_ir.Union_t _ (tr, _) _ _,
Micheline.Prim loc Alpha_context.Script.D_Right (cons v []) annot) =>
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.union))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat traced
(parse_data type_logger ctxt legacy tr v))
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
Error_monad.__return ((Script_typed_ir.R v), ctxt))))
|
(Script_typed_ir.Union_t _ _ _ _,
Micheline.Prim loc Alpha_context.Script.D_Right l _) =>
Pervasives.op_atat Error_monad.fail extensible_type_value
| (Script_typed_ir.Union_t _ _ _ _, expr) =>
traced
(Error_monad.fail
(unexpected expr [] Script_tc_errors.Constant_namespace
[ Alpha_context.Script.D_Left; Alpha_context.Script.D_Right ]))
|
(Script_typed_ir.Lambda_t ta tr _ty_name,
(Micheline.Seq _loc _) as script_instr) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.lambda))
(fun ctxt =>
Pervasives.op_atat traced
(parse_returning type_logger Lambda ctxt legacy
(ta,
(Some
(* ❌ Variants not supported *)
(* ❌ `Var_annot *)
(Var_annot "@arg"))) tr script_instr))
| (Script_typed_ir.Lambda_t _ _ _, expr) =>
traced (Error_monad.fail extensible_type_value)
|
(Script_typed_ir.Option_t __t_value _ _,
Micheline.Prim loc Alpha_context.Script.D_Some (cons v []) annot) =>
Error_monad.op_gtgteqquestion
(if legacy then
Error_monad.__return tt
else
Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.some))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat traced
(parse_data type_logger ctxt legacy __t_value v))
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
Error_monad.__return ((Some v), ctxt))))
|
(Script_typed_ir.Option_t _ _ _,
Micheline.Prim loc Alpha_context.Script.D_Some l _) =>
Pervasives.op_atat Error_monad.fail extensible_type_value
|
(Script_typed_ir.Option_t _ _ _,
Micheline.Prim loc Alpha_context.Script.D_None [] annot) =>
Error_monad.op_gtgteqquestion
(if legacy then
Error_monad.__return tt
else
Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.none))
(fun ctxt => Error_monad.__return (None, ctxt)))
|
(Script_typed_ir.Option_t _ _ _,
Micheline.Prim loc Alpha_context.Script.D_None l _) =>
Pervasives.op_atat Error_monad.fail extensible_type_value
| (Script_typed_ir.Option_t _ _ _, expr) =>
traced
(Error_monad.fail
(unexpected expr [] Script_tc_errors.Constant_namespace
[ Alpha_context.Script.D_Some; Alpha_context.Script.D_None ]))
| (Script_typed_ir.List_t __t_value _ty_name _, Micheline.Seq _loc items)
=>
Pervasives.op_atat traced
(Error_monad.fold_right_s
(fun v =>
fun function_parameter =>
let '(rest, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.list_element))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(parse_data type_logger ctxt legacy __t_value v)
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
Error_monad.__return ((cons v rest), ctxt)))) items
([], ctxt))
| (Script_typed_ir.List_t _ _ _, expr) =>
traced (Error_monad.fail extensible_type_value)
|
(Script_typed_ir.Set_t __t_value _ty_name,
(Micheline.Seq loc vs) as expr) =>
let length := List.length vs in
Error_monad.op_gtgtpipequestion
(Pervasives.op_atat traced
(Error_monad.fold_left_s
(fun function_parameter =>
let '(last_value, set, ctxt) := function_parameter in
fun v =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt
(Typecheck_costs.set_element length)))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(parse_comparable_data type_logger ctxt __t_value v)
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
match last_value with
| Some value =>
if
(|Compare.Int|).(Compare.S.op_lteq) 0
(compare_comparable __t_value value v) then
if
(|Compare.Int|).(Compare.S.op_eq) 0
(compare_comparable __t_value value v) then
Error_monad.fail extensible_type_value
else
Error_monad.fail extensible_type_value
else
Error_monad.return_unit
| None => Error_monad.return_unit
end
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Legacy.set_update
v false set)))
(fun ctxt =>
Error_monad.__return
((Some v), (set_update v true set), ctxt))))))
(None, (empty_set __t_value), ctxt) vs))
(fun function_parameter =>
let '(_, set, ctxt) := function_parameter in
(set, ctxt))
| (Script_typed_ir.Set_t _ _, expr) =>
traced (Error_monad.fail extensible_type_value)
| (Script_typed_ir.Map_t tk tv _ty_name _, (Micheline.Seq loc vs) as expr)
=> parse_items type_logger loc ctxt expr tk tv vs (fun x => x)
| (Script_typed_ir.Map_t _ _ _ _, expr) =>
traced (Error_monad.fail extensible_type_value)
|
(Script_typed_ir.Big_map_t tk tv _ty_name,
(Micheline.Seq loc vs) as expr) =>
Error_monad.op_gtgtpipequestion
(parse_items type_logger loc ctxt expr tk tv vs (fun x => Some x))
(fun function_parameter =>
let '(diff, ctxt) := function_parameter in
({|
Script_typed_ir.big_map.id := None; Script_typed_ir.big_map.diff :=
diff; Script_typed_ir.big_map.key_type := ty_of_comparable_ty tk; Script_typed_ir.big_map.value_type :=
tv |}, ctxt))
| (Script_typed_ir.Big_map_t tk tv _ty_name, Micheline.Int loc id) =>
Error_monad.op_gtgteqquestion (Alpha_context.Big_map.__exists ctxt id)
(fun function_parameter =>
match function_parameter with
| (_, None) => traced (Error_monad.fail extensible_type_value)
| (ctxt, Some (btk, btv)) =>
Lwt.__return
(Error_monad.op_gtgtquestion
(parse_comparable_ty ctxt (Micheline.root btk))
(fun function_parameter =>
let '(Ex_comparable_ty btk, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(parse_packable_ty ctxt legacy (Micheline.root btv))
(fun function_parameter =>
let '(Ex_ty btv, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(comparable_ty_eq ctxt tk btk)
(fun function_parameter =>
let 'Eq := function_parameter in
Error_monad.op_gtgtquestion (ty_eq ctxt tv btv)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.ok
({|
Script_typed_ir.big_map.id := Some id; Script_typed_ir.big_map.diff :=
empty_map tk; Script_typed_ir.big_map.key_type :=
ty_of_comparable_ty tk; Script_typed_ir.big_map.value_type :=
tv |}, ctxt))))))
end)
| (Script_typed_ir.Big_map_t _tk _tv _, expr) =>
traced (Error_monad.fail extensible_type_value)
end)
with parse_comparable_data {a : Set}
(type_logger : option type_logger) (ctxt : Alpha_context.context)
(ty : Script_typed_ir.comparable_ty a)
(script_data : Alpha_context.Script.node) {struct type_logger}
: Lwt.t (Error_monad.tzresult (a * Alpha_context.context)) :=
parse_data type_logger ctxt false (ty_of_comparable_ty ty) script_data
with parse_returning {arg ret : Set}
(type_logger : option type_logger) (tc_context : tc_context)
(ctxt : Alpha_context.context) (legacy : bool)
(function_parameter :
Script_typed_ir.ty arg * option Script_typed_ir.var_annot)
{struct type_logger}
: Script_typed_ir.ty ret -> Alpha_context.Script.node ->
Lwt.t
(Error_monad.tzresult
(Script_typed_ir.lambda arg ret * Alpha_context.context)) :=
let '(arg, arg_annot) := function_parameter in
fun ret =>
fun script_instr =>
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy script_instr
(Script_typed_ir.Item_t arg Script_typed_ir.Empty_t arg_annot))
(fun function_parameter =>
match function_parameter with
|
(Typed
({|
Script_typed_ir.descr.loc := loc;
Script_typed_ir.descr.aft :=
(Script_typed_ir.Item_t ty
Script_typed_ir.Empty_t _) as
stack_ty
|} as __descr_value), ctxt) =>
Error_monad.trace_eval
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return (serialize_ty_for_error ctxt ret))
(fun function_parameter =>
let '(ret, ctxt) := function_parameter in
Error_monad.op_gtgtpipequestion
(serialize_stack_for_error ctxt stack_ty)
(fun function_parameter =>
let '(stack_ty, _ctxt) := function_parameter in
extensible_type_value)))
(Error_monad.op_gtgteqquestion (Lwt.__return (ty_eq ctxt ty ret))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return (merge_types legacy ctxt loc ty ret))
(fun function_parameter =>
let '(_ret, ctxt) := function_parameter in
Error_monad.__return
((Script_typed_ir.Lam __descr_value script_instr), ctxt))))
|
(Typed {|
Script_typed_ir.descr.loc := loc;
Script_typed_ir.descr.aft := stack_ty
|}, ctxt) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (serialize_ty_for_error ctxt ret))
(fun function_parameter =>
let '(ret, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(serialize_stack_for_error ctxt stack_ty)
(fun function_parameter =>
let '(stack_ty, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value))
| (Failed {| judgement.Failed.descr := __descr_value |}, ctxt) =>
Error_monad.__return
((Script_typed_ir.Lam
(__descr_value
(Script_typed_ir.Item_t ret Script_typed_ir.Empty_t None))
script_instr), ctxt)
end)
with parse_int32
(n : Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
{struct n} : Error_monad.tzresult Z :=
let error' (function_parameter : unit) : Error_monad.__error :=
let '_ := function_parameter in
extensible_type_value in
match n with
| Micheline.Int _ n' =>
(* ❌ Try-with are not handled *)
try
(let n'' := Z.to_int n' in
if
Pervasives.op_andand ((|Compare.Int|).(Compare.S.op_lteq) 0 n'')
((|Compare.Int|).(Compare.S.op_lteq) n'' (Int32.to_int Int32.max_int))
then
Error_monad.ok n''
else
Pervasives.op_atat Error_monad.__error_value (error' tt))
| _ => Pervasives.op_atat Error_monad.__error_value (error' tt)
end
with parse_instr {bef : Set}
(type_logger : option type_logger) (tc_context : tc_context)
(ctxt : Alpha_context.context) (legacy : bool)
(script_instr : Alpha_context.Script.node)
(stack_ty : Script_typed_ir.stack_ty bef) {struct type_logger}
: Lwt.t (Error_monad.tzresult (judgement bef * Alpha_context.context)) :=
let _check_item {B : Set}
(check : Error_monad.tzresult B) (loc : Alpha_context.Script.location)
(name : Alpha_context.Script.prim) (n : Z) (m : Z)
: Lwt.t (Error_monad.tzresult B) :=
Pervasives.op_atat
(Error_monad.trace_eval
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgtpipequestion
(serialize_stack_for_error ctxt stack_ty)
(fun function_parameter =>
let '(stack_ty, _ctxt) := function_parameter in
extensible_type_value)))
(Pervasives.op_atat (Error_monad.trace extensible_type_value)
(Lwt.__return check)) in
let check_item_ty {B C : Set}
(ctxt : Alpha_context.context) (exp : Script_typed_ir.ty B)
(got : Script_typed_ir.ty C) (loc : Alpha_context.Script.location)
(name : Alpha_context.Script.prim) (n : Z) (m : Z)
: Lwt.t
(Error_monad.tzresult
(eq B C * Script_typed_ir.ty B * Alpha_context.context)) :=
Pervasives.op_atat
(Error_monad.trace_eval
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgtpipequestion
(serialize_stack_for_error ctxt stack_ty)
(fun function_parameter =>
let '(stack_ty, _ctxt) := function_parameter in
extensible_type_value)))
(Pervasives.op_atat (Error_monad.trace extensible_type_value)
(Lwt.__return
(Error_monad.op_gtgtquestion (ty_eq ctxt exp got)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgtquestion (merge_types legacy ctxt loc exp got)
(fun function_parameter =>
let '(ty, ctxt) := function_parameter in
Error_monad.ok (Eq, ty, ctxt)))))) in
let check_item_comparable_ty {B C : Set}
(exp : Script_typed_ir.comparable_ty B)
(got : Script_typed_ir.comparable_ty C)
(loc : Alpha_context.Script.location) (name : Alpha_context.Script.prim)
(n : Z) (m : Z)
: Lwt.t (Error_monad.tzresult (eq B C * Script_typed_ir.comparable_ty B)) :=
Pervasives.op_atat
(Error_monad.trace_eval
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgtpipequestion
(serialize_stack_for_error ctxt stack_ty)
(fun function_parameter =>
let '(stack_ty, _ctxt) := function_parameter in
extensible_type_value)))
(Pervasives.op_atat (Error_monad.trace extensible_type_value)
(Lwt.__return
(Error_monad.op_gtgtquestion (comparable_ty_eq ctxt exp got)
(fun function_parameter =>
let 'Eq := function_parameter in
Error_monad.op_gtgtquestion
(merge_comparable_types legacy exp got)
(fun ty => Error_monad.ok (Eq, ty)))))) in
let log_stack {B C : Set}
(ctxt : Alpha_context.context) (loc : Z)
(stack_ty : Script_typed_ir.stack_ty B) (aft : Script_typed_ir.stack_ty C)
: Lwt.t (Error_monad.tzresult unit) :=
match (type_logger, script_instr) with
|
(None, _) |
(Some _,
Micheline.Seq (-1) _ | Micheline.Int _ _ | Micheline.String _ _ |
Micheline.Bytes _ _) => Error_monad.return_unit
| (Some log, Micheline.Prim _ _ _ _ | Micheline.Seq _ _) =>
let ctxt := Alpha_context.Gas.set_unlimited ctxt in
Error_monad.op_gtgteqquestion (unparse_stack ctxt stack_ty)
(fun function_parameter =>
let '(stack_ty, _) := function_parameter in
Error_monad.op_gtgteqquestion (unparse_stack ctxt aft)
(fun function_parameter =>
let '(aft, _) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
(* ❌ instruction_sequence ";" *)
Error_monad.return_unit))
end in
let outer_return := Error_monad.__return in
let __return (ctxt : Alpha_context.context) (judgement : judgement bef)
: Lwt.t (Error_monad.tzresult (judgement bef * Alpha_context.context)) :=
match judgement with
|
Typed {|
Script_typed_ir.descr.loc := loc;
Script_typed_ir.descr.aft := aft;
Script_typed_ir.descr.instr := instr
|} =>
let maximum_type_size :=
Alpha_context.Constants.michelson_maximum_type_size ctxt in
let type_size :=
type_size_of_stack_head aft (number_of_generated_growing_types instr) in
if (|Compare.Int|).(Compare.S.op_gt) type_size maximum_type_size then
Error_monad.fail extensible_type_value
else
Error_monad.__return (judgement, ctxt)
| Failed _ => Error_monad.__return (judgement, ctxt)
end in
let typed {B : Set}
(ctxt : Alpha_context.context) (loc : Z)
(instr : Script_typed_ir.instr bef B) (aft : Script_typed_ir.stack_ty B)
: Lwt.t (Error_monad.tzresult (judgement bef * Alpha_context.context)) :=
Error_monad.op_gtgteqquestion (log_stack ctxt loc stack_ty aft)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Alpha_context.Gas.consume ctxt (Typecheck_costs.instr instr)))
(fun ctxt =>
__return ctxt
(Typed
{|
Script_typed_ir.descr.loc := loc; Script_typed_ir.descr.bef :=
stack_ty; Script_typed_ir.descr.aft := aft; Script_typed_ir.descr.instr :=
instr |}))) in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
match
((script_instr, stack_ty),
match (script_instr, stack_ty) with
|
(Micheline.Prim loc Alpha_context.Script.I_DIP
(cons n (cons code [])) result_annot, stack) =>
match parse_int32 n with
| Pervasives.Ok _ => true
| Pervasives.Error _ => false
end
| _ => false
end) with
|
((Micheline.Prim loc Alpha_context.Script.I_DROP [] annot,
Script_typed_ir.Item_t _ rest _), _) =>
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
typed ctxt loc Script_typed_ir.Drop rest)
|
((Micheline.Prim loc Alpha_context.Script.I_DROP (cons n [])
result_annot, whole_stack), _) =>
Error_monad.op_gtgteqquestion (Lwt.__return (parse_int32 n))
(fun whole_n =>
let fix make_proof_argument {tstk : Set}
(n : Z) (stk : Script_typed_ir.stack_ty tstk) {struct n}
: Lwt.t (Error_monad.tzresult (dropn_proof_argument tstk)) :=
match (((|Compare.Int|).(Compare.S.op_eq) n 0), stk) with
| (true, rest) =>
Pervasives.op_atat outer_return
(Dropn_proof_argument (Script_typed_ir.Rest, rest, rest))
| (false, Script_typed_ir.Item_t v rest annot) =>
Error_monad.op_gtgteqquestion
(make_proof_argument (Pervasives.op_minus n 1) rest)
(fun function_parameter =>
let 'Dropn_proof_argument (n', stack_after_drops, aft') :=
function_parameter in
Pervasives.op_atat outer_return
(Dropn_proof_argument
((Script_typed_ir.Prefix n'), stack_after_drops,
(Script_typed_ir.Item_t v aft' annot))))
| (_, _) =>
Error_monad.op_gtgteqquestion
(serialize_stack_for_error ctxt whole_stack)
(fun function_parameter =>
let '(whole_stack, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value)
end in
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc result_annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(make_proof_argument whole_n whole_stack)
(fun function_parameter =>
let 'Dropn_proof_argument (n', stack_after_drops, _aft) :=
function_parameter in
typed ctxt loc (Script_typed_ir.Dropn whole_n n')
stack_after_drops)))
|
((Micheline.Prim loc Alpha_context.Script.I_DROP
((cons _ (cons _ _)) as l) _, _), _) =>
Error_monad.fail extensible_type_value
|
((Micheline.Prim loc Alpha_context.Script.I_DUP [] annot,
Script_typed_ir.Item_t v rest stack_annot), _) =>
Error_monad.op_gtgteqquestion
(parse_var_annot loc (Some stack_annot) annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Dup
(Script_typed_ir.Item_t v
(Script_typed_ir.Item_t v rest stack_annot) annot))
|
((Micheline.Prim loc Alpha_context.Script.I_DIG (cons n []) result_annot,
stack), _) =>
let fix make_proof_argument {tstk : Set}
(n : Z) (stk : Script_typed_ir.stack_ty tstk) {struct n}
: Lwt.t (Error_monad.tzresult (dig_proof_argument tstk)) :=
match (((|Compare.Int|).(Compare.S.op_eq) n 0), stk) with
| (true, Script_typed_ir.Item_t v rest annot) =>
Pervasives.op_atat outer_return
(Dig_proof_argument (Script_typed_ir.Rest, (v, annot), rest))
| (false, Script_typed_ir.Item_t v rest annot) =>
Error_monad.op_gtgteqquestion
(make_proof_argument (Pervasives.op_minus n 1) rest)
(fun function_parameter =>
let 'Dig_proof_argument (n', (x, xv), aft') :=
function_parameter in
Pervasives.op_atat outer_return
(Dig_proof_argument
((Script_typed_ir.Prefix n'), (x, xv),
(Script_typed_ir.Item_t v aft' annot))))
| (_, _) =>
Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(whole_stack, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value)
end in
Error_monad.op_gtgteqquestion (Lwt.__return (parse_int32 n))
(fun n =>
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc result_annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion (make_proof_argument n stack)
(fun function_parameter =>
let 'Dig_proof_argument (n', (x, stack_annot), aft) :=
function_parameter in
typed ctxt loc (Script_typed_ir.Dig n n')
(Script_typed_ir.Item_t x aft stack_annot))))
|
((Micheline.Prim loc Alpha_context.Script.I_DIG
(([] | cons _ (cons _ _)) as l) _, _), _) =>
Error_monad.fail extensible_type_value
|
((Micheline.Prim loc Alpha_context.Script.I_DUG (cons n []) result_annot,
Script_typed_ir.Item_t x whole_stack stack_annot), _) =>
Error_monad.op_gtgteqquestion (Lwt.__return (parse_int32 n))
(fun whole_n =>
let fix make_proof_argument {tstk x : Set}
(n : Z) (x : Script_typed_ir.ty x)
(stack_annot : option Script_typed_ir.var_annot)
(stk : Script_typed_ir.stack_ty tstk) {struct n}
: Lwt.t (Error_monad.tzresult (dug_proof_argument tstk x)) :=
match (((|Compare.Int|).(Compare.S.op_eq) n 0), stk) with
| (true, rest) =>
Pervasives.op_atat outer_return
(Dug_proof_argument
(Script_typed_ir.Rest, tt,
(Script_typed_ir.Item_t x rest stack_annot)))
| (false, Script_typed_ir.Item_t v rest annot) =>
Error_monad.op_gtgteqquestion
(make_proof_argument (Pervasives.op_minus n 1) x stack_annot
rest)
(fun function_parameter =>
let 'Dug_proof_argument (n', _, aft') := function_parameter
in
Pervasives.op_atat outer_return
(Dug_proof_argument
((Script_typed_ir.Prefix n'), tt,
(Script_typed_ir.Item_t v aft' annot))))
| (_, _) =>
Error_monad.op_gtgteqquestion
(serialize_stack_for_error ctxt whole_stack)
(fun function_parameter =>
let '(whole_stack, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value)
end in
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc result_annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(make_proof_argument whole_n x stack_annot whole_stack)
(fun function_parameter =>
let 'Dug_proof_argument (n', _, aft) := function_parameter
in
typed ctxt loc (Script_typed_ir.Dug whole_n n') aft)))
|
((Micheline.Prim loc Alpha_context.Script.I_DUG (cons _ []) result_annot,
Script_typed_ir.Empty_t as stack), _) =>
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc result_annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value))
|
((Micheline.Prim loc Alpha_context.Script.I_DUG
(([] | cons _ (cons _ _)) as l) _, _), _) =>
Error_monad.fail extensible_type_value
|
((Micheline.Prim loc Alpha_context.Script.I_SWAP [] annot,
Script_typed_ir.Item_t v (Script_typed_ir.Item_t w rest stack_annot)
cur_top_annot), _) =>
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
typed ctxt loc Script_typed_ir.Swap
(Script_typed_ir.Item_t w
(Script_typed_ir.Item_t v rest cur_top_annot) stack_annot))
|
((Micheline.Prim loc Alpha_context.Script.I_PUSH
(cons __t_value (cons d [])) annot, stack), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(parse_packable_ty ctxt legacy __t_value))
(fun function_parameter =>
let '(Ex_ty __t_value, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(parse_data type_logger ctxt legacy __t_value d)
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
typed ctxt loc (Script_typed_ir.Const v)
(Script_typed_ir.Item_t __t_value stack annot))))
| ((Micheline.Prim loc Alpha_context.Script.I_UNIT [] annot, stack), _) =>
Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, ty_name) := function_parameter in
typed ctxt loc (Script_typed_ir.Const tt)
(Script_typed_ir.Item_t (Script_typed_ir.Unit_t ty_name) stack
annot))
|
((Micheline.Prim loc Alpha_context.Script.I_SOME [] annot,
Script_typed_ir.Item_t __t_value rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, ty_name) := function_parameter in
typed ctxt loc Script_typed_ir.Cons_some
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t __t_value ty_name
(has_big_map __t_value)) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_NONE (cons __t_value [])
annot, stack), _) =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy __t_value))
(fun function_parameter =>
let '(Ex_ty __t_value, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, ty_name) := function_parameter in
typed ctxt loc (Script_typed_ir.Cons_none __t_value)
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t __t_value ty_name
(has_big_map __t_value)) stack annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_IF_NONE
(cons bt (cons bf [])) annot,
(Script_typed_ir.Item_t (Script_typed_ir.Option_t __t_value _ _) rest
option_annot) as bef), _) =>
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] bt)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] bf)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
let annot :=
Script_ir_annot.gen_access_annot option_annot None
Script_ir_annot.default_some_annot in
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bt rest)
(fun function_parameter =>
let '(btr, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bf
(Script_typed_ir.Item_t __t_value rest annot))
(fun function_parameter =>
let '(bfr, ctxt) := function_parameter in
let branch {B : Set}
(ibt : Script_typed_ir.descr __57 B)
(ibf : Script_typed_ir.descr (__58 * __57) B)
: Script_typed_ir.descr (option __58 * __57) B :=
{|
Script_typed_ir.descr.loc := loc; Script_typed_ir.descr.bef :=
bef; Script_typed_ir.descr.aft :=
Script_typed_ir.descr.aft ibt; Script_typed_ir.descr.instr :=
Script_typed_ir.If_none ibt ibf |} in
Error_monad.op_gtgteqquestion
(merge_branches legacy ctxt loc btr bfr
{| branch.branch := branch |})
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
__return ctxt judgement))))))
|
((Micheline.Prim loc Alpha_context.Script.I_PAIR [] annot,
Script_typed_ir.Item_t a (Script_typed_ir.Item_t b rest snd_annot)
fst_annot), _) =>
Error_monad.op_gtgteqquestion
(parse_constr_annot loc
(Some (Script_ir_annot.var_to_field_annot fst_annot))
(Some (Script_ir_annot.var_to_field_annot snd_annot)) annot)
(fun function_parameter =>
let '(annot, ty_name, l_field, r_field) := function_parameter in
typed ctxt loc Script_typed_ir.Cons_pair
(Script_typed_ir.Item_t
(Script_typed_ir.Pair_t (a, l_field, fst_annot)
(b, r_field, snd_annot) ty_name
(Pervasives.op_pipepipe (has_big_map a) (has_big_map b))) rest
annot))
|
((Micheline.Prim loc Alpha_context.Script.I_CAR [] annot,
Script_typed_ir.Item_t
(Script_typed_ir.Pair_t (a, expected_field_annot, a_annot) _ _ _)
rest pair_annot), _) =>
Error_monad.op_gtgteqquestion
(parse_destr_annot loc annot Script_ir_annot.default_car_annot
expected_field_annot pair_annot a_annot)
(fun function_parameter =>
let '(annot, field_annot) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.check_correct_field field_annot
expected_field_annot))
(fun function_parameter =>
let '_ := function_parameter in
typed ctxt loc Script_typed_ir.Car
(Script_typed_ir.Item_t a rest annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_CDR [] annot,
Script_typed_ir.Item_t
(Script_typed_ir.Pair_t _ (b, expected_field_annot, b_annot) _ _)
rest pair_annot), _) =>
Error_monad.op_gtgteqquestion
(parse_destr_annot loc annot Script_ir_annot.default_cdr_annot
expected_field_annot pair_annot b_annot)
(fun function_parameter =>
let '(annot, field_annot) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.check_correct_field field_annot
expected_field_annot))
(fun function_parameter =>
let '_ := function_parameter in
typed ctxt loc Script_typed_ir.Cdr
(Script_typed_ir.Item_t b rest annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_LEFT (cons tr []) annot,
Script_typed_ir.Item_t tl rest stack_annot), _) =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy tr))
(fun function_parameter =>
let '(Ex_ty tr, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(parse_constr_annot loc
(Some (Script_ir_annot.var_to_field_annot stack_annot)) None
annot)
(fun function_parameter =>
let '(annot, tname, l_field, r_field) := function_parameter in
typed ctxt loc Script_typed_ir.Left
(Script_typed_ir.Item_t
(Script_typed_ir.Union_t (tl, l_field) (tr, r_field) tname
(Pervasives.op_pipepipe (has_big_map tl) (has_big_map tr)))
rest annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_RIGHT (cons tl []) annot,
Script_typed_ir.Item_t tr rest stack_annot), _) =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy tl))
(fun function_parameter =>
let '(Ex_ty tl, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(parse_constr_annot loc None
(Some (Script_ir_annot.var_to_field_annot stack_annot)) annot)
(fun function_parameter =>
let '(annot, tname, l_field, r_field) := function_parameter in
typed ctxt loc Script_typed_ir.Right
(Script_typed_ir.Item_t
(Script_typed_ir.Union_t (tl, l_field) (tr, r_field) tname
(Pervasives.op_pipepipe (has_big_map tl) (has_big_map tr)))
rest annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_IF_LEFT
(cons bt (cons bf [])) annot,
(Script_typed_ir.Item_t
(Script_typed_ir.Union_t (tl, l_field) (tr, r_field) _ _) rest
union_annot) as bef), _) =>
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] bt)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] bf)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
let left_annot :=
Script_ir_annot.gen_access_annot union_annot
(Some Script_ir_annot.default_left_annot) l_field in
let right_annot :=
Script_ir_annot.gen_access_annot union_annot
(Some Script_ir_annot.default_right_annot) r_field in
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bt
(Script_typed_ir.Item_t tl rest left_annot))
(fun function_parameter =>
let '(btr, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bf
(Script_typed_ir.Item_t tr rest right_annot))
(fun function_parameter =>
let '(bfr, ctxt) := function_parameter in
let branch {B : Set}
(ibt : Script_typed_ir.descr (__77 * __76) B)
(ibf : Script_typed_ir.descr (__78 * __76) B)
: Script_typed_ir.descr
(Script_typed_ir.union __77 __78 * __76) B :=
{|
Script_typed_ir.descr.loc := loc; Script_typed_ir.descr.bef :=
bef; Script_typed_ir.descr.aft :=
Script_typed_ir.descr.aft ibt; Script_typed_ir.descr.instr :=
Script_typed_ir.If_left ibt ibf |} in
Error_monad.op_gtgteqquestion
(merge_branches legacy ctxt loc btr bfr
{| branch.branch := branch |})
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
__return ctxt judgement))))))
|
((Micheline.Prim loc Alpha_context.Script.I_NIL (cons __t_value [])
annot, stack), _) =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy __t_value))
(fun function_parameter =>
let '(Ex_ty __t_value, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, ty_name) := function_parameter in
typed ctxt loc Script_typed_ir.Nil
(Script_typed_ir.Item_t
(Script_typed_ir.List_t __t_value ty_name
(has_big_map __t_value)) stack annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_CONS [] annot,
Script_typed_ir.Item_t tv
(Script_typed_ir.Item_t
(Script_typed_ir.List_t __t_value ty_name has_big_map) rest _) _),
_) =>
Error_monad.op_gtgteqquestion
(check_item_ty ctxt tv __t_value loc Alpha_context.Script.I_CONS 1 2)
(fun function_parameter =>
let '(Eq, __t_value, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Cons_list
(Script_typed_ir.Item_t
(Script_typed_ir.List_t __t_value ty_name has_big_map) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_IF_CONS
(cons bt (cons bf [])) annot,
(Script_typed_ir.Item_t
(Script_typed_ir.List_t __t_value ty_name has_big_map) rest
list_annot) as bef), _) =>
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] bt)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] bf)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
let hd_annot :=
Script_ir_annot.gen_access_annot list_annot None
Script_ir_annot.default_hd_annot in
let tl_annot :=
Script_ir_annot.gen_access_annot list_annot None
Script_ir_annot.default_tl_annot in
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bt
(Script_typed_ir.Item_t __t_value
(Script_typed_ir.Item_t
(Script_typed_ir.List_t __t_value ty_name
has_big_map) rest tl_annot) hd_annot))
(fun function_parameter =>
let '(btr, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bf
rest)
(fun function_parameter =>
let '(bfr, ctxt) := function_parameter in
let branch {B : Set}
(ibt :
Script_typed_ir.descr
(__86 * (list __86 * __85)) B)
(ibf : Script_typed_ir.descr __85 B)
: Script_typed_ir.descr (list __86 * __85) B :=
{|
Script_typed_ir.descr.loc := loc; Script_typed_ir.descr.bef :=
bef; Script_typed_ir.descr.aft :=
Script_typed_ir.descr.aft ibt; Script_typed_ir.descr.instr :=
Script_typed_ir.If_cons ibt ibf |} in
Error_monad.op_gtgteqquestion
(merge_branches legacy ctxt loc btr bfr
{| branch.branch := branch |})
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
__return ctxt judgement))))))
|
((Micheline.Prim loc Alpha_context.Script.I_SIZE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.List_t _ _ _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, tname) := function_parameter in
typed ctxt loc Script_typed_ir.List_size
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_MAP (cons body []) annot,
Script_typed_ir.Item_t (Script_typed_ir.List_t elt _ _) starting_rest
list_annot), _) =>
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] body)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(ret_annot, list_ty_name) := function_parameter in
let elt_annot :=
Script_ir_annot.gen_access_annot list_annot None
Script_ir_annot.default_elt_annot in
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy body
(Script_typed_ir.Item_t elt starting_rest elt_annot))
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
|
Typed
({|
Script_typed_ir.descr.aft := Script_typed_ir.Item_t ret rest _
|} as ibody) =>
let invalid_map_body (function_parameter : unit)
: Lwt.t (Error_monad.tzresult Error_monad.__error) :=
let '_ := function_parameter in
Error_monad.op_gtgtpipequestion
(serialize_stack_for_error ctxt
(Script_typed_ir.descr.aft ibody))
(fun function_parameter =>
let '(aft, _ctxt) := function_parameter in
extensible_type_value) in
Error_monad.trace_eval invalid_map_body
(Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(stack_ty_eq ctxt 1 rest starting_rest))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(merge_stacks legacy loc ctxt rest starting_rest))
(fun function_parameter =>
let '(rest, ctxt) := function_parameter in
typed ctxt loc (Script_typed_ir.List_map ibody)
(Script_typed_ir.Item_t
(Script_typed_ir.List_t ret list_ty_name
(has_big_map ret)) rest ret_annot))))
| Typed {| Script_typed_ir.descr.aft := aft |} =>
Error_monad.op_gtgteqquestion
(serialize_stack_for_error ctxt aft)
(fun function_parameter =>
let '(aft, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value)
| Failed _ => Error_monad.fail extensible_type_value
end)))
|
((Micheline.Prim loc Alpha_context.Script.I_ITER (cons body []) annot,
Script_typed_ir.Item_t (Script_typed_ir.List_t elt _ _) rest
list_annot), _) =>
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] body)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
let elt_annot :=
Script_ir_annot.gen_access_annot list_annot None
Script_ir_annot.default_elt_annot in
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy body
(Script_typed_ir.Item_t elt rest elt_annot))
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed ({| Script_typed_ir.descr.aft := aft |} as ibody) =>
let invalid_iter_body (function_parameter : unit)
: Lwt.t (Error_monad.tzresult Error_monad.__error) :=
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(serialize_stack_for_error ctxt
(Script_typed_ir.descr.aft ibody))
(fun function_parameter =>
let '(aft, ctxt) := function_parameter in
Error_monad.op_gtgtpipequestion
(serialize_stack_for_error ctxt rest)
(fun function_parameter =>
let '(rest, _ctxt) := function_parameter in
extensible_type_value)) in
Error_monad.trace_eval invalid_iter_body
(Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(stack_ty_eq ctxt 1 aft rest))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(merge_stacks legacy loc ctxt aft rest))
(fun function_parameter =>
let '(rest, ctxt) := function_parameter in
typed ctxt loc (Script_typed_ir.List_iter ibody)
rest)))
| Failed {| judgement.Failed.descr := __descr_value |} =>
typed ctxt loc
(Script_typed_ir.List_iter (__descr_value rest)) rest
end)))
|
((Micheline.Prim loc Alpha_context.Script.I_EMPTY_SET
(cons __t_value []) annot, rest), _) =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (parse_comparable_ty ctxt __t_value))
(fun function_parameter =>
let '(Ex_comparable_ty __t_value, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, tname) := function_parameter in
typed ctxt loc (Script_typed_ir.Empty_set __t_value)
(Script_typed_ir.Item_t
(Script_typed_ir.Set_t __t_value tname) rest annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_ITER (cons body []) annot,
Script_typed_ir.Item_t (Script_typed_ir.Set_t comp_elt _) rest
set_annot), _) =>
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] body)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
let elt_annot :=
Script_ir_annot.gen_access_annot set_annot None
Script_ir_annot.default_elt_annot in
let elt := ty_of_comparable_ty comp_elt in
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy body
(Script_typed_ir.Item_t elt rest elt_annot))
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed ({| Script_typed_ir.descr.aft := aft |} as ibody) =>
let invalid_iter_body (function_parameter : unit)
: Lwt.t (Error_monad.tzresult Error_monad.__error) :=
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(serialize_stack_for_error ctxt
(Script_typed_ir.descr.aft ibody))
(fun function_parameter =>
let '(aft, ctxt) := function_parameter in
Error_monad.op_gtgtpipequestion
(serialize_stack_for_error ctxt rest)
(fun function_parameter =>
let '(rest, _ctxt) := function_parameter in
extensible_type_value)) in
Error_monad.trace_eval invalid_iter_body
(Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(stack_ty_eq ctxt 1 aft rest))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(merge_stacks legacy loc ctxt aft rest))
(fun function_parameter =>
let '(rest, ctxt) := function_parameter in
typed ctxt loc (Script_typed_ir.Set_iter ibody)
rest)))
| Failed {| judgement.Failed.descr := __descr_value |} =>
typed ctxt loc
(Script_typed_ir.Set_iter (__descr_value rest)) rest
end)))
|
((Micheline.Prim loc Alpha_context.Script.I_MEM [] annot,
Script_typed_ir.Item_t v
(Script_typed_ir.Item_t (Script_typed_ir.Set_t elt _) rest _) _), _)
=>
let elt := ty_of_comparable_ty elt in
Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, tname) := function_parameter in
Error_monad.op_gtgteqquestion
(check_item_ty ctxt elt v loc Alpha_context.Script.I_MEM 1 2)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
typed ctxt loc Script_typed_ir.Set_mem
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_UPDATE [] annot,
Script_typed_ir.Item_t v
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Set_t elt tname) rest
set_annot) _) _), _) =>
match comparable_ty_of_ty v with
| None =>
Error_monad.op_gtgteqquestion (unparse_ty ctxt v)
(fun function_parameter =>
let '(v, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value)
| Some v =>
Error_monad.op_gtgteqquestion
(parse_var_annot loc (Some set_annot) annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(check_item_comparable_ty elt v loc
Alpha_context.Script.I_UPDATE 1 3)
(fun function_parameter =>
let '(Eq, elt) := function_parameter in
typed ctxt loc Script_typed_ir.Set_update
(Script_typed_ir.Item_t (Script_typed_ir.Set_t elt tname)
rest annot)))
end
|
((Micheline.Prim loc Alpha_context.Script.I_SIZE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Set_t _ _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Set_size
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_EMPTY_MAP
(cons tk (cons tv [])) annot, stack), _) =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (parse_comparable_ty ctxt tk))
(fun function_parameter =>
let '(Ex_comparable_ty tk, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy tv))
(fun function_parameter =>
let '(Ex_ty tv, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, ty_name) := function_parameter in
typed ctxt loc (Script_typed_ir.Empty_map tk tv)
(Script_typed_ir.Item_t
(Script_typed_ir.Map_t tk tv ty_name (has_big_map tv))
stack annot))))
|
((Micheline.Prim loc Alpha_context.Script.I_MAP (cons body []) annot,
Script_typed_ir.Item_t (Script_typed_ir.Map_t ck elt _ _)
starting_rest _map_annot), _) =>
let k := ty_of_comparable_ty ck in
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] body)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(ret_annot, ty_name) := function_parameter in
let k_name :=
Script_ir_annot.field_to_var_annot
Script_ir_annot.default_key_annot in
let e_name :=
Script_ir_annot.field_to_var_annot
Script_ir_annot.default_elt_annot in
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy body
(Script_typed_ir.Item_t
(Script_typed_ir.Pair_t (k, None, k_name)
(elt, None, e_name) None (has_big_map elt))
starting_rest None))
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
|
Typed
({|
Script_typed_ir.descr.aft := Script_typed_ir.Item_t ret rest _
|} as ibody) =>
let invalid_map_body (function_parameter : unit)
: Lwt.t (Error_monad.tzresult Error_monad.__error) :=
let '_ := function_parameter in
Error_monad.op_gtgtpipequestion
(serialize_stack_for_error ctxt
(Script_typed_ir.descr.aft ibody))
(fun function_parameter =>
let '(aft, _ctxt) := function_parameter in
extensible_type_value) in
Error_monad.trace_eval invalid_map_body
(Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(stack_ty_eq ctxt 1 rest starting_rest))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(merge_stacks legacy loc ctxt rest starting_rest))
(fun function_parameter =>
let '(rest, ctxt) := function_parameter in
typed ctxt loc (Script_typed_ir.Map_map ibody)
(Script_typed_ir.Item_t
(Script_typed_ir.Map_t ck ret ty_name
(has_big_map ret)) rest ret_annot))))
| Typed {| Script_typed_ir.descr.aft := aft |} =>
Error_monad.op_gtgteqquestion
(serialize_stack_for_error ctxt aft)
(fun function_parameter =>
let '(aft, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value)
| Failed _ => Error_monad.fail extensible_type_value
end)))
|
((Micheline.Prim loc Alpha_context.Script.I_ITER (cons body []) annot,
Script_typed_ir.Item_t (Script_typed_ir.Map_t comp_elt element_ty _ _)
rest _map_annot), _) =>
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] body)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
let k_name :=
Script_ir_annot.field_to_var_annot
Script_ir_annot.default_key_annot in
let e_name :=
Script_ir_annot.field_to_var_annot
Script_ir_annot.default_elt_annot in
let key := ty_of_comparable_ty comp_elt in
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy body
(Script_typed_ir.Item_t
(Script_typed_ir.Pair_t (key, None, k_name)
(element_ty, None, e_name) None (has_big_map element_ty))
rest None))
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed ({| Script_typed_ir.descr.aft := aft |} as ibody) =>
let invalid_iter_body (function_parameter : unit)
: Lwt.t (Error_monad.tzresult Error_monad.__error) :=
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(serialize_stack_for_error ctxt
(Script_typed_ir.descr.aft ibody))
(fun function_parameter =>
let '(aft, ctxt) := function_parameter in
Error_monad.op_gtgtpipequestion
(serialize_stack_for_error ctxt rest)
(fun function_parameter =>
let '(rest, _ctxt) := function_parameter in
extensible_type_value)) in
Error_monad.trace_eval invalid_iter_body
(Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(stack_ty_eq ctxt 1 aft rest))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(merge_stacks legacy loc ctxt aft rest))
(fun function_parameter =>
let '(rest, ctxt) := function_parameter in
typed ctxt loc (Script_typed_ir.Map_iter ibody)
rest)))
| Failed {| judgement.Failed.descr := __descr_value |} =>
typed ctxt loc
(Script_typed_ir.Map_iter (__descr_value rest)) rest
end)))
|
((Micheline.Prim loc Alpha_context.Script.I_MEM [] annot,
Script_typed_ir.Item_t vk
(Script_typed_ir.Item_t (Script_typed_ir.Map_t ck _ _ _) rest _) _),
_) =>
let k := ty_of_comparable_ty ck in
Error_monad.op_gtgteqquestion
(check_item_ty ctxt vk k loc Alpha_context.Script.I_MEM 1 2)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Map_mem
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_GET [] annot,
Script_typed_ir.Item_t vk
(Script_typed_ir.Item_t (Script_typed_ir.Map_t ck elt _ has_big_map)
rest _) _), _) =>
let k := ty_of_comparable_ty ck in
Error_monad.op_gtgteqquestion
(check_item_ty ctxt vk k loc Alpha_context.Script.I_GET 1 2)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Map_get
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t elt None has_big_map) rest annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_UPDATE [] annot,
Script_typed_ir.Item_t vk
(Script_typed_ir.Item_t (Script_typed_ir.Option_t vv _ _)
(Script_typed_ir.Item_t
(Script_typed_ir.Map_t ck v map_name has_big_map) rest map_annot)
_) _), _) =>
let k := ty_of_comparable_ty ck in
Error_monad.op_gtgteqquestion
(check_item_ty ctxt vk k loc Alpha_context.Script.I_UPDATE 1 3)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(check_item_ty ctxt vv v loc Alpha_context.Script.I_UPDATE 2 3)
(fun function_parameter =>
let '(Eq, v, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(parse_var_annot loc (Some map_annot) annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Map_update
(Script_typed_ir.Item_t
(Script_typed_ir.Map_t ck v map_name has_big_map) rest
annot))))
|
((Micheline.Prim loc Alpha_context.Script.I_SIZE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Map_t _ _ _ _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Map_size
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_EMPTY_BIG_MAP
(cons tk (cons tv [])) annot, stack), _) =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (parse_comparable_ty ctxt tk))
(fun function_parameter =>
let '(Ex_comparable_ty tk, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(parse_packable_ty ctxt legacy tv))
(fun function_parameter =>
let '(Ex_ty tv, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, ty_name) := function_parameter in
typed ctxt loc (Script_typed_ir.Empty_big_map tk tv)
(Script_typed_ir.Item_t
(Script_typed_ir.Big_map_t tk tv ty_name) stack annot))))
|
((Micheline.Prim loc Alpha_context.Script.I_MEM [] annot,
Script_typed_ir.Item_t set_key
(Script_typed_ir.Item_t (Script_typed_ir.Big_map_t map_key _ _) rest
_) _), _) =>
let k := ty_of_comparable_ty map_key in
Error_monad.op_gtgteqquestion
(check_item_ty ctxt set_key k loc Alpha_context.Script.I_MEM 1 2)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Big_map_mem
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_GET [] annot,
Script_typed_ir.Item_t vk
(Script_typed_ir.Item_t (Script_typed_ir.Big_map_t ck elt _) rest _)
_), _) =>
let k := ty_of_comparable_ty ck in
Error_monad.op_gtgteqquestion
(check_item_ty ctxt vk k loc Alpha_context.Script.I_GET 1 2)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Big_map_get
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t elt None (has_big_map elt)) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_UPDATE [] annot,
Script_typed_ir.Item_t set_key
(Script_typed_ir.Item_t (Script_typed_ir.Option_t set_value _ _)
(Script_typed_ir.Item_t
(Script_typed_ir.Big_map_t map_key map_value map_name) rest
map_annot) _) _), _) =>
let k := ty_of_comparable_ty map_key in
Error_monad.op_gtgteqquestion
(check_item_ty ctxt set_key k loc Alpha_context.Script.I_UPDATE 1 3)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(check_item_ty ctxt set_value map_value loc
Alpha_context.Script.I_UPDATE 2 3)
(fun function_parameter =>
let '(Eq, map_value, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(parse_var_annot loc (Some map_annot) annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Big_map_update
(Script_typed_ir.Item_t
(Script_typed_ir.Big_map_t map_key map_value map_name)
rest annot))))
| ((Micheline.Seq loc [], stack), _) =>
typed ctxt loc Script_typed_ir.Nop stack
| ((Micheline.Seq loc (cons single []), stack), _) =>
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy single stack)
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed ({| Script_typed_ir.descr.aft := aft |} as instr) =>
let nop :=
{|
Script_typed_ir.descr.loc := loc; Script_typed_ir.descr.bef :=
aft; Script_typed_ir.descr.aft := aft; Script_typed_ir.descr.instr :=
Script_typed_ir.Nop |} in
typed ctxt loc (Script_typed_ir.Seq instr nop) aft
| Failed {| judgement.Failed.descr := __descr_value |} =>
let __descr_value {B : Set} (aft : Script_typed_ir.stack_ty B)
: Script_typed_ir.descr bef B :=
let nop :=
{|
Script_typed_ir.descr.loc := loc; Script_typed_ir.descr.bef :=
aft; Script_typed_ir.descr.aft := aft; Script_typed_ir.descr.instr :=
Script_typed_ir.Nop |} in
let __descr_value := __descr_value aft in
Script_typed_ir.descr.with_instr __descr_value
(Script_typed_ir.Seq __descr_value nop) in
__return ctxt
(Failed {| judgement.Failed.descr := __descr_value |})
end)
| ((Micheline.Seq loc (cons hd tl), stack), _) =>
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy hd stack)
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Failed _ => Error_monad.fail extensible_type_value
| Typed ({| Script_typed_ir.descr.aft := middle |} as ihd) =>
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy
(Micheline.Seq (-1) tl) middle)
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Failed {| judgement.Failed.descr := __descr_value |} =>
let __descr_value {B : Set}
(ret : Script_typed_ir.stack_ty B)
: Script_typed_ir.descr bef B :=
{|
Script_typed_ir.descr.loc := loc; Script_typed_ir.descr.bef :=
stack; Script_typed_ir.descr.aft := ret; Script_typed_ir.descr.instr :=
Script_typed_ir.Seq ihd (__descr_value ret) |} in
__return ctxt
(Failed {| judgement.Failed.descr := __descr_value |})
| Typed itl =>
typed ctxt loc (Script_typed_ir.Seq ihd itl)
(Script_typed_ir.descr.aft itl)
end)
end)
|
((Micheline.Prim loc Alpha_context.Script.I_IF (cons bt (cons bf []))
annot,
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t _) rest _) as bef), _)
=>
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] bt)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] bf)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bt rest)
(fun function_parameter =>
let '(btr, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bf
rest)
(fun function_parameter =>
let '(bfr, ctxt) := function_parameter in
let branch {B : Set}
(ibt : Script_typed_ir.descr __169 B)
(ibf : Script_typed_ir.descr __169 B)
: Script_typed_ir.descr (bool * __169) B :=
{|
Script_typed_ir.descr.loc := loc; Script_typed_ir.descr.bef :=
bef; Script_typed_ir.descr.aft :=
Script_typed_ir.descr.aft ibt; Script_typed_ir.descr.instr :=
Script_typed_ir.If ibt ibf |} in
Error_monad.op_gtgteqquestion
(merge_branches legacy ctxt loc btr bfr
{| branch.branch := branch |})
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
__return ctxt judgement))))))
|
((Micheline.Prim loc Alpha_context.Script.I_LOOP (cons body []) annot,
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t _) rest _stack_annot)
as stack), _) =>
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] body)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy body rest)
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed ibody =>
let unmatched_branches (function_parameter : unit)
: Lwt.t (Error_monad.tzresult Error_monad.__error) :=
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(serialize_stack_for_error ctxt
(Script_typed_ir.descr.aft ibody))
(fun function_parameter =>
let '(aft, ctxt) := function_parameter in
Error_monad.op_gtgtpipequestion
(serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
extensible_type_value)) in
Error_monad.trace_eval unmatched_branches
(Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(stack_ty_eq ctxt 1
(Script_typed_ir.descr.aft ibody) stack))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(merge_stacks legacy loc ctxt
(Script_typed_ir.descr.aft ibody) stack))
(fun function_parameter =>
let '(_stack, ctxt) := function_parameter in
typed ctxt loc (Script_typed_ir.Loop ibody) rest)))
| Failed {| judgement.Failed.descr := __descr_value |} =>
let ibody := __descr_value stack in
typed ctxt loc (Script_typed_ir.Loop ibody) rest
end)))
|
((Micheline.Prim loc Alpha_context.Script.I_LOOP_LEFT (cons body [])
annot,
(Script_typed_ir.Item_t
(Script_typed_ir.Union_t (tl, l_field) (tr, _) _ _) rest union_annot)
as stack), _) =>
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] body)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
let l_annot :=
Script_ir_annot.gen_access_annot union_annot
(Some Script_ir_annot.default_left_annot) l_field in
Error_monad.op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy body
(Script_typed_ir.Item_t tl rest l_annot))
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed ibody =>
let unmatched_branches (function_parameter : unit)
: Lwt.t (Error_monad.tzresult Error_monad.__error) :=
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(serialize_stack_for_error ctxt
(Script_typed_ir.descr.aft ibody))
(fun function_parameter =>
let '(aft, ctxt) := function_parameter in
Error_monad.op_gtgtpipequestion
(serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
extensible_type_value)) in
Error_monad.trace_eval unmatched_branches
(Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(stack_ty_eq ctxt 1
(Script_typed_ir.descr.aft ibody) stack))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(merge_stacks legacy loc ctxt
(Script_typed_ir.descr.aft ibody) stack))
(fun function_parameter =>
let '(_stack, ctxt) := function_parameter in
typed ctxt loc (Script_typed_ir.Loop_left ibody)
(Script_typed_ir.Item_t tr rest annot))))
| Failed {| judgement.Failed.descr := __descr_value |} =>
let ibody := __descr_value stack in
typed ctxt loc (Script_typed_ir.Loop_left ibody)
(Script_typed_ir.Item_t tr rest annot)
end)))
|
((Micheline.Prim loc Alpha_context.Script.I_LAMBDA
(cons arg (cons ret (cons code []))) annot, stack), _) =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy arg))
(fun function_parameter =>
let '(Ex_ty arg, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy ret))
(fun function_parameter =>
let '(Ex_ty ret, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] code)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(parse_returning type_logger Lambda ctxt legacy
(arg, Script_ir_annot.default_arg_annot) ret code)
(fun function_parameter =>
let '(lambda, ctxt) := function_parameter in
typed ctxt loc (Script_typed_ir.Lambda lambda)
(Script_typed_ir.Item_t
(Script_typed_ir.Lambda_t arg ret None) stack
annot))))))
|
((Micheline.Prim loc Alpha_context.Script.I_EXEC [] annot,
Script_typed_ir.Item_t arg
(Script_typed_ir.Item_t (Script_typed_ir.Lambda_t param ret _) rest
_) _), _) =>
Error_monad.op_gtgteqquestion
(check_item_ty ctxt arg param loc Alpha_context.Script.I_EXEC 1 2)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Exec
(Script_typed_ir.Item_t ret rest annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_APPLY [] annot,
Script_typed_ir.Item_t capture
(Script_typed_ir.Item_t
(Script_typed_ir.Lambda_t
(Script_typed_ir.Pair_t (capture_ty, _, _) (arg_ty, _, _)
lam_annot _) ret _) rest _) _), _) =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (check_packable false loc capture_ty))
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(check_item_ty ctxt capture capture_ty loc
Alpha_context.Script.I_APPLY 1 2)
(fun function_parameter =>
let '(Eq, capture_ty, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc (Script_typed_ir.Apply capture_ty)
(Script_typed_ir.Item_t
(Script_typed_ir.Lambda_t arg_ty ret lam_annot) rest
annot))))
|
((Micheline.Prim loc Alpha_context.Script.I_DIP (cons code []) annot,
Script_typed_ir.Item_t v rest stack_annot), _) =>
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(check_kind [ Script_tc_errors.Seq_kind ] code)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(parse_instr type_logger (add_dip v stack_annot tc_context)
ctxt legacy code rest)
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed __descr_value =>
typed ctxt loc (Script_typed_ir.Dip __descr_value)
(Script_typed_ir.Item_t v
(Script_typed_ir.descr.aft __descr_value) stack_annot)
| Failed _ => Error_monad.fail extensible_type_value
end)))
|
((Micheline.Prim loc Alpha_context.Script.I_DIP (cons n (cons code []))
result_annot, stack), true) =>
let fix make_proof_argument {tstk : Set}
(n : Z) (inner_tc_context : tc_context)
(stk : Script_typed_ir.stack_ty tstk) {struct n}
: Lwt.t (Error_monad.tzresult (dipn_proof_argument tstk)) :=
match (((|Compare.Int|).(Compare.S.op_eq) n 0), stk) with
| (true, rest) =>
Error_monad.op_gtgteqquestion
(parse_instr type_logger inner_tc_context ctxt legacy code rest)
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed __descr_value =>
Pervasives.op_atat outer_return
(Dipn_proof_argument
(Script_typed_ir.Rest, (ctxt, __descr_value),
(Script_typed_ir.descr.aft __descr_value)))
| Failed _ => Error_monad.fail extensible_type_value
end)
| (false, Script_typed_ir.Item_t v rest annot) =>
Error_monad.op_gtgteqquestion
(make_proof_argument (Pervasives.op_minus n 1)
(add_dip v annot tc_context) rest)
(fun function_parameter =>
let 'Dipn_proof_argument (n', __descr_value, aft') :=
function_parameter in
Pervasives.op_atat outer_return
(Dipn_proof_argument
((Script_typed_ir.Prefix n'), __descr_value,
(Script_typed_ir.Item_t v aft' annot))))
| (_, _) =>
Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(whole_stack, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value)
end in
Error_monad.op_gtgteqquestion (Lwt.__return (parse_int32 n))
(fun n =>
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc result_annot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(make_proof_argument n tc_context stack)
(fun function_parameter =>
let
'Dipn_proof_argument (n', (new_ctxt, __descr_value), aft) :=
function_parameter in
typed new_ctxt loc (Script_typed_ir.Dipn n n' __descr_value)
aft)))
|
((Micheline.Prim loc Alpha_context.Script.I_DIP
(([] | cons _ (cons _ (cons _ _))) as l) _, _), _) =>
Error_monad.fail extensible_type_value
|
((Micheline.Prim loc Alpha_context.Script.I_FAILWITH [] annot,
Script_typed_ir.Item_t v _rest _), _) =>
Error_monad.op_gtgteqquestion
(Script_ir_annot.fail_unexpected_annot loc annot)
(fun function_parameter =>
let '_ := function_parameter in
let __descr_value {B : Set} (aft : Script_typed_ir.stack_ty B)
: Script_typed_ir.descr bef B :=
{|
Script_typed_ir.descr.loc := loc; Script_typed_ir.descr.bef :=
stack_ty; Script_typed_ir.descr.aft := aft; Script_typed_ir.descr.instr :=
Script_typed_ir.Failwith v |} in
Error_monad.op_gtgteqquestion
(log_stack ctxt loc stack_ty Script_typed_ir.Empty_t)
(fun function_parameter =>
let '_ := function_parameter in
__return ctxt
(Failed {| judgement.Failed.descr := __descr_value |})))
|
((Micheline.Prim loc Alpha_context.Script.I_ADD [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tname)
(Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _) _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Add_timestamp_to_seconds
(Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tname) rest
annot))
|
((Micheline.Prim loc Alpha_context.Script.I_ADD [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tname) rest _)
_), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Add_seconds_to_timestamp
(Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tname) rest
annot))
|
((Micheline.Prim loc Alpha_context.Script.I_SUB [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tname)
(Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _) _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Sub_timestamp_seconds
(Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tname) rest
annot))
|
((Micheline.Prim loc Alpha_context.Script.I_SUB [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t tn2) rest _) _),
_) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Diff_timestamps
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_CONCAT [] annot,
Script_typed_ir.Item_t (Script_typed_ir.String_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.String_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Concat_string_pair
(Script_typed_ir.Item_t (Script_typed_ir.String_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_CONCAT [] annot,
Script_typed_ir.Item_t
(Script_typed_ir.List_t (Script_typed_ir.String_t tname) _ _) rest
list_annot), _) =>
Error_monad.op_gtgteqquestion
(parse_var_annot loc (Some list_annot) annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Concat_string
(Script_typed_ir.Item_t (Script_typed_ir.String_t tname) rest
annot))
|
((Micheline.Prim loc Alpha_context.Script.I_SLICE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
(Script_typed_ir.Item_t (Script_typed_ir.String_t tname) rest
string_annot) _) _), _) =>
Error_monad.op_gtgteqquestion
(parse_var_annot loc
(Some
(Script_ir_annot.gen_access_annot string_annot None
Script_ir_annot.default_slice_annot)) annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Slice_string
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t (Script_typed_ir.String_t tname) None
false) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_SIZE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.String_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.String_size
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_CONCAT [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Bytes_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Bytes_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Concat_bytes_pair
(Script_typed_ir.Item_t (Script_typed_ir.Bytes_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_CONCAT [] annot,
Script_typed_ir.Item_t
(Script_typed_ir.List_t (Script_typed_ir.Bytes_t tname) _ _) rest
list_annot), _) =>
Error_monad.op_gtgteqquestion
(parse_var_annot loc (Some list_annot) annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Concat_bytes
(Script_typed_ir.Item_t (Script_typed_ir.Bytes_t tname) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_SLICE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Bytes_t tname) rest
bytes_annot) _) _), _) =>
Error_monad.op_gtgteqquestion
(parse_var_annot loc
(Some
(Script_ir_annot.gen_access_annot bytes_annot None
Script_ir_annot.default_slice_annot)) annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Slice_bytes
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t (Script_typed_ir.Bytes_t tname) None
false) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_SIZE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Bytes_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Bytes_size
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_ADD [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Add_tez
(Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_SUB [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Sub_tez
(Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_MUL [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tname)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _) _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Mul_teznat
(Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tname) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_MUL [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tname) rest _) _),
_) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Mul_nattez
(Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tname) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_OR [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Bool_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Or
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_AND [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Bool_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.And
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_XOR [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Bool_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Xor
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_NOT [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Bool_t tname) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Not
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t tname) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_ABS [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Abs_int
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_ISNAT [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest int_annot), _)
=>
Error_monad.op_gtgteqquestion
(parse_var_annot loc (Some int_annot) annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Is_nat
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t (Script_typed_ir.Nat_t None) None
false) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_INT [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Int_nat
(Script_typed_ir.Item_t (Script_typed_ir.Int_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_NEG [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Neg_int
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_NEG [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Neg_nat
(Script_typed_ir.Item_t (Script_typed_ir.Int_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_ADD [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Add_intint
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_ADD [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t tname)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _) _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Add_intnat
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_ADD [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Add_natint
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_ADD [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Add_natnat
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_SUB [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Sub_int
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_SUB [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t tname)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _) _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Sub_int
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_SUB [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Sub_int
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_SUB [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun _tname =>
typed ctxt loc Script_typed_ir.Sub_int
(Script_typed_ir.Item_t (Script_typed_ir.Int_t None) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_MUL [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Mul_intint
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_MUL [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t tname)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _) _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Mul_intnat
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_MUL [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Mul_natint
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_MUL [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Mul_natnat
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_EDIV [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tname)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _) _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Ediv_teznat
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t
(Script_typed_ir.Pair_t
((Script_typed_ir.Mutez_t tname), None, None)
((Script_typed_ir.Mutez_t tname), None, None) None false)
None false) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_EDIV [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Mutez_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Ediv_tez
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t
(Script_typed_ir.Pair_t
((Script_typed_ir.Nat_t None), None, None)
((Script_typed_ir.Mutez_t tname), None, None) None false)
None false) rest annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_EDIV [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Ediv_intint
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t
(Script_typed_ir.Pair_t
((Script_typed_ir.Int_t tname), None, None)
((Script_typed_ir.Nat_t None), None, None) None false)
None false) rest annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_EDIV [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t tname)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _) _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Ediv_intnat
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t
(Script_typed_ir.Pair_t
((Script_typed_ir.Int_t tname), None, None)
((Script_typed_ir.Nat_t None), None, None) None false) None
false) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_EDIV [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname)
(Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _) _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Ediv_natint
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t
(Script_typed_ir.Pair_t
((Script_typed_ir.Int_t None), None, None)
((Script_typed_ir.Nat_t tname), None, None) None false) None
false) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_EDIV [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Ediv_natnat
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t
(Script_typed_ir.Pair_t
((Script_typed_ir.Nat_t tname), None, None)
((Script_typed_ir.Nat_t tname), None, None) None false)
None false) rest annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_LSL [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Lsl_nat
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_LSR [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Lsr_nat
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_OR [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Or_nat
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_AND [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.And_nat
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_AND [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.And_int_nat
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_XOR [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn1)
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tn2) rest _) _), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Script_ir_annot.merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Script_typed_ir.Xor_nat
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t tname) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_NOT [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Not_int
(Script_typed_ir.Item_t (Script_typed_ir.Int_t tname) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_NOT [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Nat_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Not_nat
(Script_typed_ir.Item_t (Script_typed_ir.Int_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_COMPARE [] annot,
Script_typed_ir.Item_t t1 (Script_typed_ir.Item_t t2 rest _) _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(check_item_ty ctxt t1 t2 loc Alpha_context.Script.I_COMPARE 1 2)
(fun function_parameter =>
let '(Eq, __t_value, ctxt) := function_parameter in
match comparable_ty_of_ty __t_value with
| None =>
Error_monad.op_gtgteqquestion
(Lwt.__return (serialize_ty_for_error ctxt __t_value))
(fun function_parameter =>
let '(__t_value, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value)
| Some key =>
typed ctxt loc (Script_typed_ir.Compare key)
(Script_typed_ir.Item_t (Script_typed_ir.Int_t None) rest
annot)
end))
|
((Micheline.Prim loc Alpha_context.Script.I_EQ [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Eq
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_NEQ [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Neq
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_LT [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Lt
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_GT [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Gt
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_LE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Le
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_GE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Int_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Ge
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_CAST (cons cast_t []) annot,
Script_typed_ir.Item_t __t_value stack item_annot), _) =>
Error_monad.op_gtgteqquestion
(parse_var_annot loc (Some item_annot) annot)
(fun annot =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (parse_any_ty ctxt legacy cast_t))
(fun function_parameter =>
let '(Ex_ty cast_t, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (ty_eq ctxt cast_t __t_value))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(merge_types legacy ctxt loc cast_t __t_value))
(fun function_parameter =>
let '(_, ctxt) := function_parameter in
typed ctxt loc Script_typed_ir.Nop
(Script_typed_ir.Item_t cast_t stack annot)))))
|
((Micheline.Prim loc Alpha_context.Script.I_RENAME [] annot,
Script_typed_ir.Item_t __t_value stack _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Nop
(Script_typed_ir.Item_t __t_value stack annot))
|
((Micheline.Prim loc Alpha_context.Script.I_PACK [] annot,
Script_typed_ir.Item_t __t_value rest unpacked_annot), _) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (check_packable true loc __t_value))
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(parse_var_annot loc
(Some
(Script_ir_annot.gen_access_annot unpacked_annot None
Script_ir_annot.default_pack_annot)) annot)
(fun annot =>
typed ctxt loc (Script_typed_ir.Pack __t_value)
(Script_typed_ir.Item_t (Script_typed_ir.Bytes_t None) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_UNPACK (cons ty []) annot,
Script_typed_ir.Item_t (Script_typed_ir.Bytes_t _) rest packed_annot),
_) =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (parse_packable_ty ctxt legacy ty))
(fun function_parameter =>
let '(Ex_ty __t_value, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, ty_name) := function_parameter in
let annot :=
Script_ir_annot.default_annot
(Script_ir_annot.gen_access_annot packed_annot None
Script_ir_annot.default_unpack_annot) annot in
typed ctxt loc (Script_typed_ir.Unpack __t_value)
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t __t_value ty_name false) rest
annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_ADDRESS [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Contract_t _ _) rest
contract_annot), _) =>
Error_monad.op_gtgteqquestion
(parse_var_annot loc
(Some
(Script_ir_annot.gen_access_annot contract_annot None
Script_ir_annot.default_addr_annot)) annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Address
(Script_typed_ir.Item_t (Script_typed_ir.Address_t None) rest
annot))
|
((Micheline.Prim loc Alpha_context.Script.I_CONTRACT (cons ty []) annot,
Script_typed_ir.Item_t (Script_typed_ir.Address_t _) rest addr_annot),
_) =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (parse_parameter_ty ctxt legacy ty))
(fun function_parameter =>
let '(Ex_ty __t_value, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(parse_entrypoint_annot loc
(Some
(Script_ir_annot.gen_access_annot addr_annot None
Script_ir_annot.default_contract_annot)) annot)
(fun function_parameter =>
let '(annot, entrypoint) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
match entrypoint with
| None => Pervasives.Ok "default"
| Some (Field_annot "default") =>
Error_monad.__error_value extensible_type_value
| Some (Field_annot entrypoint) =>
if
(|Compare.Int|).(Compare.S.op_gt)
(String.length entrypoint) 31 then
Error_monad.__error_value extensible_type_value
else
Pervasives.Ok entrypoint
end)
(fun entrypoint =>
typed ctxt loc
(Script_typed_ir.Contract __t_value entrypoint)
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t
(Script_typed_ir.Contract_t __t_value None) None false)
rest annot))))
|
((Micheline.Prim loc Alpha_context.Script.I_TRANSFER_TOKENS [] annot,
Script_typed_ir.Item_t p
(Script_typed_ir.Item_t (Script_typed_ir.Mutez_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Contract_t cp _) rest _)
_) _), _) =>
Error_monad.op_gtgteqquestion
(check_item_ty ctxt p cp loc Alpha_context.Script.I_TRANSFER_TOKENS 1
4)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Transfer_tokens
(Script_typed_ir.Item_t (Script_typed_ir.Operation_t None)
rest annot)))
|
((Micheline.Prim loc Alpha_context.Script.I_SET_DELEGATE [] annot,
Script_typed_ir.Item_t
(Script_typed_ir.Option_t (Script_typed_ir.Key_hash_t _) _ _) rest _),
_) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Set_delegate
(Script_typed_ir.Item_t (Script_typed_ir.Operation_t None) rest
annot))
|
((Micheline.Prim loc Alpha_context.Script.I_CREATE_ACCOUNT [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Key_hash_t _)
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t (Script_typed_ir.Key_hash_t _) _ _)
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Mutez_t _) rest _) _) _)
_), _) =>
if legacy then
Error_monad.op_gtgteqquestion (parse_two_var_annot loc annot)
(fun function_parameter =>
let '(op_annot, addr_annot) := function_parameter in
typed ctxt loc Script_typed_ir.Create_account
(Script_typed_ir.Item_t (Script_typed_ir.Operation_t None)
(Script_typed_ir.Item_t (Script_typed_ir.Address_t None) rest
addr_annot) op_annot))
else
Error_monad.fail extensible_type_value
|
((Micheline.Prim loc Alpha_context.Script.I_IMPLICIT_ACCOUNT [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Key_hash_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Implicit_account
(Script_typed_ir.Item_t
(Script_typed_ir.Contract_t (Script_typed_ir.Unit_t None) None)
rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_CREATE_CONTRACT
(cons ((Micheline.Seq _ _) as code) []) annot,
Script_typed_ir.Item_t (Script_typed_ir.Key_hash_t _)
(Script_typed_ir.Item_t
(Script_typed_ir.Option_t (Script_typed_ir.Key_hash_t _) _ _)
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Mutez_t _)
(Script_typed_ir.Item_t ginit rest _) _) _) _) _) _), _) =>
if legacy then
Error_monad.op_gtgteqquestion (parse_two_var_annot loc annot)
(fun function_parameter =>
let '(op_annot, addr_annot) := function_parameter in
let cannonical_code :=
Pervasives.op_atat Pervasives.fst
(Micheline.extract_locations code) in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(parse_toplevel legacy cannonical_code))
(fun function_parameter =>
let '(arg_type, storage_type, code_field, root_name) :=
function_parameter in
Error_monad.op_gtgteqquestion
(Error_monad.trace extensible_type_value
(Pervasives.op_atat Lwt.__return
(parse_parameter_ty ctxt legacy arg_type)))
(fun function_parameter =>
let '(Ex_ty arg_type, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(if legacy then
Error_monad.__return tt
else
Lwt.__return
(well_formed_entrypoints arg_type root_name))
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Error_monad.trace extensible_type_value
(Pervasives.op_atat Lwt.__return
(parse_storage_ty ctxt legacy storage_type)))
(fun function_parameter =>
let '(Ex_ty storage_type, ctxt) :=
function_parameter in
let arg_annot :=
Script_ir_annot.default_annot
Script_ir_annot.default_param_annot
(Script_ir_annot.type_to_var_annot
(name_of_ty arg_type)) in
let storage_annot :=
Script_ir_annot.default_annot
Script_ir_annot.default_storage_annot
(Script_ir_annot.type_to_var_annot
(name_of_ty storage_type)) in
let arg_type_full :=
Script_typed_ir.Pair_t
(arg_type, None, arg_annot)
(storage_type, None, storage_annot) None
(Pervasives.op_pipepipe (has_big_map arg_type)
(has_big_map storage_type)) in
let ret_type_full :=
Script_typed_ir.Pair_t
((Script_typed_ir.List_t
(Script_typed_ir.Operation_t None) None
false), None, None)
(storage_type, None, None) None
(has_big_map storage_type) in
Error_monad.op_gtgteqquestion
(Error_monad.trace extensible_type_value
(parse_returning type_logger
(Toplevel
{|
tc_context.Toplevel.storage_type :=
storage_type; tc_context.Toplevel.param_type :=
arg_type; tc_context.Toplevel.root_name :=
root_name; tc_context.Toplevel.legacy_create_contract_literal :=
true |}) ctxt legacy
(arg_type_full, None) ret_type_full
code_field))
(fun function_parameter =>
let
'((Script_typed_ir.Lam {|
Script_typed_ir.descr.bef :=
Script_typed_ir.Item_t arg
Script_typed_ir.Empty_t
_;
Script_typed_ir.descr.aft :=
Script_typed_ir.Item_t
ret
Script_typed_ir.Empty_t
_
|} _) as lambda, ctxt) :=
function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(ty_eq ctxt arg arg_type_full))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(merge_types legacy ctxt loc arg
arg_type_full))
(fun function_parameter =>
let '(_, ctxt) := function_parameter
in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(ty_eq ctxt ret ret_type_full))
(fun function_parameter =>
let '(Eq, ctxt) :=
function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(merge_types legacy ctxt loc
ret ret_type_full))
(fun function_parameter =>
let '(_, ctxt) :=
function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat
Lwt.__return
(ty_eq ctxt storage_type
ginit))
(fun function_parameter =>
let '(Eq, ctxt) :=
function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat
Lwt.__return
(merge_types legacy
ctxt loc
storage_type ginit))
(fun function_parameter
=>
let '(_, ctxt) :=
function_parameter
in
typed ctxt loc
(Script_typed_ir.Create_contract
storage_type
arg_type lambda
root_name)
(Script_typed_ir.Item_t
(Script_typed_ir.Operation_t
None)
(Script_typed_ir.Item_t
(Script_typed_ir.Address_t
None) rest
addr_annot)
op_annot)))))))))))))
else
Error_monad.fail extensible_type_value
|
((Micheline.Prim loc Alpha_context.Script.I_CREATE_CONTRACT
(cons ((Micheline.Seq _ _) as code) []) annot,
Script_typed_ir.Item_t
(Script_typed_ir.Option_t (Script_typed_ir.Key_hash_t _) _ _)
(Script_typed_ir.Item_t (Script_typed_ir.Mutez_t _)
(Script_typed_ir.Item_t ginit rest _) _) _), _) =>
Error_monad.op_gtgteqquestion (parse_two_var_annot loc annot)
(fun function_parameter =>
let '(op_annot, addr_annot) := function_parameter in
let cannonical_code :=
Pervasives.op_atat Pervasives.fst
(Micheline.extract_locations code) in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(parse_toplevel legacy cannonical_code))
(fun function_parameter =>
let '(arg_type, storage_type, code_field, root_name) :=
function_parameter in
Error_monad.op_gtgteqquestion
(Error_monad.trace extensible_type_value
(Pervasives.op_atat Lwt.__return
(parse_parameter_ty ctxt legacy arg_type)))
(fun function_parameter =>
let '(Ex_ty arg_type, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(if legacy then
Error_monad.__return tt
else
Lwt.__return
(well_formed_entrypoints arg_type root_name))
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Error_monad.trace extensible_type_value
(Pervasives.op_atat Lwt.__return
(parse_storage_ty ctxt legacy storage_type)))
(fun function_parameter =>
let '(Ex_ty storage_type, ctxt) :=
function_parameter in
let arg_annot :=
Script_ir_annot.default_annot
Script_ir_annot.default_param_annot
(Script_ir_annot.type_to_var_annot
(name_of_ty arg_type)) in
let storage_annot :=
Script_ir_annot.default_annot
Script_ir_annot.default_storage_annot
(Script_ir_annot.type_to_var_annot
(name_of_ty storage_type)) in
let arg_type_full :=
Script_typed_ir.Pair_t (arg_type, None, arg_annot)
(storage_type, None, storage_annot) None
(Pervasives.op_pipepipe (has_big_map arg_type)
(has_big_map storage_type)) in
let ret_type_full :=
Script_typed_ir.Pair_t
((Script_typed_ir.List_t
(Script_typed_ir.Operation_t None) None false),
None, None) (storage_type, None, None) None
(has_big_map storage_type) in
Error_monad.op_gtgteqquestion
(Error_monad.trace extensible_type_value
(parse_returning type_logger
(Toplevel
{|
tc_context.Toplevel.storage_type :=
storage_type; tc_context.Toplevel.param_type :=
arg_type; tc_context.Toplevel.root_name :=
root_name; tc_context.Toplevel.legacy_create_contract_literal :=
false |}) ctxt legacy
(arg_type_full, None) ret_type_full code_field))
(fun function_parameter =>
let
'((Script_typed_ir.Lam {|
Script_typed_ir.descr.bef :=
Script_typed_ir.Item_t arg
Script_typed_ir.Empty_t
_;
Script_typed_ir.descr.aft :=
Script_typed_ir.Item_t
ret
Script_typed_ir.Empty_t
_
|} _) as lambda, ctxt) :=
function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(ty_eq ctxt arg arg_type_full))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(merge_types legacy ctxt loc arg
arg_type_full))
(fun function_parameter =>
let '(_, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(ty_eq ctxt ret ret_type_full))
(fun function_parameter =>
let '(Eq, ctxt) :=
function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(merge_types legacy ctxt loc ret
ret_type_full))
(fun function_parameter =>
let '(_, ctxt) :=
function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat
Lwt.__return
(ty_eq ctxt storage_type
ginit))
(fun function_parameter =>
let '(Eq, ctxt) :=
function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat
Lwt.__return
(merge_types legacy ctxt
loc storage_type ginit))
(fun function_parameter =>
let '(_, ctxt) :=
function_parameter in
typed ctxt loc
(Script_typed_ir.Create_contract_2
storage_type
arg_type lambda
root_name)
(Script_typed_ir.Item_t
(Script_typed_ir.Operation_t
None)
(Script_typed_ir.Item_t
(Script_typed_ir.Address_t
None) rest
addr_annot)
op_annot)))))))))))))
| ((Micheline.Prim loc Alpha_context.Script.I_NOW [] annot, stack), _) =>
Error_monad.op_gtgteqquestion
(parse_var_annot loc (Some Script_ir_annot.default_now_annot) annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Now
(Script_typed_ir.Item_t (Script_typed_ir.Timestamp_t None) stack
annot))
| ((Micheline.Prim loc Alpha_context.Script.I_AMOUNT [] annot, stack), _)
=>
Error_monad.op_gtgteqquestion
(parse_var_annot loc (Some Script_ir_annot.default_amount_annot) annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Amount
(Script_typed_ir.Item_t (Script_typed_ir.Mutez_t None) stack annot))
|
((Micheline.Prim loc Alpha_context.Script.I_CHAIN_ID [] annot, stack), _)
=>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.ChainId
(Script_typed_ir.Item_t (Script_typed_ir.Chain_id_t None) stack
annot))
| ((Micheline.Prim loc Alpha_context.Script.I_BALANCE [] annot, stack), _)
=>
Error_monad.op_gtgteqquestion
(parse_var_annot loc (Some Script_ir_annot.default_balance_annot)
annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Balance
(Script_typed_ir.Item_t (Script_typed_ir.Mutez_t None) stack annot))
|
((Micheline.Prim loc Alpha_context.Script.I_HASH_KEY [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Key_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Hash_key
(Script_typed_ir.Item_t (Script_typed_ir.Key_hash_t None) rest
annot))
|
((Micheline.Prim loc Alpha_context.Script.I_CHECK_SIGNATURE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Key_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Signature_t _)
(Script_typed_ir.Item_t (Script_typed_ir.Bytes_t _) rest _) _) _),
_) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Check_signature
(Script_typed_ir.Item_t (Script_typed_ir.Bool_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_BLAKE2B [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Bytes_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Blake2b
(Script_typed_ir.Item_t (Script_typed_ir.Bytes_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_SHA256 [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Bytes_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Sha256
(Script_typed_ir.Item_t (Script_typed_ir.Bytes_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_SHA512 [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Bytes_t _) rest _), _) =>
Error_monad.op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Sha512
(Script_typed_ir.Item_t (Script_typed_ir.Bytes_t None) rest annot))
|
((Micheline.Prim loc Alpha_context.Script.I_STEPS_TO_QUOTA [] annot,
stack), _) =>
if legacy then
Error_monad.op_gtgteqquestion
(parse_var_annot loc (Some Script_ir_annot.default_steps_annot)
annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Steps_to_quota
(Script_typed_ir.Item_t (Script_typed_ir.Nat_t None) stack annot))
else
Error_monad.fail extensible_type_value
| ((Micheline.Prim loc Alpha_context.Script.I_SOURCE [] annot, stack), _)
=>
Error_monad.op_gtgteqquestion
(parse_var_annot loc (Some Script_ir_annot.default_source_annot) annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Source
(Script_typed_ir.Item_t (Script_typed_ir.Address_t None) stack
annot))
| ((Micheline.Prim loc Alpha_context.Script.I_SENDER [] annot, stack), _)
=>
Error_monad.op_gtgteqquestion
(parse_var_annot loc (Some Script_ir_annot.default_sender_annot) annot)
(fun annot =>
typed ctxt loc Script_typed_ir.Sender
(Script_typed_ir.Item_t (Script_typed_ir.Address_t None) stack
annot))
| ((Micheline.Prim loc Alpha_context.Script.I_SELF [] annot, stack), _) =>
Error_monad.op_gtgteqquestion
(parse_entrypoint_annot loc (Some Script_ir_annot.default_self_annot)
annot)
(fun function_parameter =>
let '(annot, entrypoint) := function_parameter in
let entrypoint :=
Option.unopt_map
(fun function_parameter =>
let 'Field_annot annot := function_parameter in
annot) "default" entrypoint in
let fix get_toplevel_type (function_parameter : tc_context)
{struct function_parameter}
: Lwt.t
(Error_monad.tzresult (judgement bef * Alpha_context.context)) :=
match function_parameter with
| Lambda => Error_monad.fail extensible_type_value
| Dip _ prev => get_toplevel_type prev
|
Toplevel {|
tc_context.Toplevel.param_type := param_type;
tc_context.Toplevel.root_name := root_name;
tc_context.Toplevel.legacy_create_contract_literal := false
|} =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(find_entrypoint param_type root_name entrypoint))
(fun function_parameter =>
let '(_, Ex_ty param_type) := function_parameter in
typed ctxt loc (Script_typed_ir.Self param_type entrypoint)
(Script_typed_ir.Item_t
(Script_typed_ir.Contract_t param_type None) stack annot))
|
Toplevel {|
tc_context.Toplevel.param_type := param_type;
tc_context.Toplevel.root_name := _;
tc_context.Toplevel.legacy_create_contract_literal := true
|} =>
typed ctxt loc (Script_typed_ir.Self param_type "default")
(Script_typed_ir.Item_t
(Script_typed_ir.Contract_t param_type None) stack annot)
end in
get_toplevel_type tc_context)
|
((Micheline.Prim loc
((Alpha_context.Script.I_DUP | Alpha_context.Script.I_SWAP |
Alpha_context.Script.I_SOME | Alpha_context.Script.I_UNIT |
Alpha_context.Script.I_PAIR | Alpha_context.Script.I_CAR |
Alpha_context.Script.I_CDR | Alpha_context.Script.I_CONS |
Alpha_context.Script.I_CONCAT | Alpha_context.Script.I_SLICE |
Alpha_context.Script.I_MEM | Alpha_context.Script.I_UPDATE |
Alpha_context.Script.I_MAP | Alpha_context.Script.I_GET |
Alpha_context.Script.I_EXEC | Alpha_context.Script.I_FAILWITH |
Alpha_context.Script.I_SIZE | Alpha_context.Script.I_ADD |
Alpha_context.Script.I_SUB | Alpha_context.Script.I_MUL |
Alpha_context.Script.I_EDIV | Alpha_context.Script.I_OR |
Alpha_context.Script.I_AND | Alpha_context.Script.I_XOR |
Alpha_context.Script.I_NOT | Alpha_context.Script.I_ABS |
Alpha_context.Script.I_NEG | Alpha_context.Script.I_LSL |
Alpha_context.Script.I_LSR | Alpha_context.Script.I_COMPARE |
Alpha_context.Script.I_EQ | Alpha_context.Script.I_NEQ |
Alpha_context.Script.I_LT | Alpha_context.Script.I_GT |
Alpha_context.Script.I_LE | Alpha_context.Script.I_GE |
Alpha_context.Script.I_TRANSFER_TOKENS |
Alpha_context.Script.I_CREATE_ACCOUNT |
Alpha_context.Script.I_SET_DELEGATE | Alpha_context.Script.I_NOW |
Alpha_context.Script.I_IMPLICIT_ACCOUNT |
Alpha_context.Script.I_AMOUNT | Alpha_context.Script.I_BALANCE |
Alpha_context.Script.I_CHECK_SIGNATURE |
Alpha_context.Script.I_HASH_KEY | Alpha_context.Script.I_SOURCE |
Alpha_context.Script.I_SENDER | Alpha_context.Script.I_BLAKE2B |
Alpha_context.Script.I_SHA256 | Alpha_context.Script.I_SHA512 |
Alpha_context.Script.I_STEPS_TO_QUOTA | Alpha_context.Script.I_ADDRESS)
as name) ((cons _ _) as l) _, _), _) =>
Error_monad.fail extensible_type_value
|
((Micheline.Prim loc
((Alpha_context.Script.I_NONE | Alpha_context.Script.I_LEFT |
Alpha_context.Script.I_RIGHT | Alpha_context.Script.I_NIL |
Alpha_context.Script.I_MAP | Alpha_context.Script.I_ITER |
Alpha_context.Script.I_EMPTY_SET | Alpha_context.Script.I_DIP |
Alpha_context.Script.I_LOOP | Alpha_context.Script.I_LOOP_LEFT |
Alpha_context.Script.I_CONTRACT) as name)
(([] | cons _ (cons _ _)) as l) _, _), _) =>
Error_monad.fail extensible_type_value
|
((Micheline.Prim loc
((Alpha_context.Script.I_PUSH | Alpha_context.Script.I_IF_NONE |
Alpha_context.Script.I_IF_LEFT | Alpha_context.Script.I_IF_CONS |
Alpha_context.Script.I_EMPTY_MAP | Alpha_context.Script.I_IF) as name)
(([] | cons _ [] | cons _ (cons _ (cons _ _))) as l) _, _), _) =>
Error_monad.fail extensible_type_value
|
((Micheline.Prim loc Alpha_context.Script.I_LAMBDA
(([] | cons _ [] | cons _ (cons _ (cons _ (cons _ _)))) as l) _, _), _)
=> Error_monad.fail extensible_type_value
|
((Micheline.Prim loc
((Alpha_context.Script.I_ADD | Alpha_context.Script.I_SUB |
Alpha_context.Script.I_MUL | Alpha_context.Script.I_EDIV |
Alpha_context.Script.I_AND | Alpha_context.Script.I_OR |
Alpha_context.Script.I_XOR | Alpha_context.Script.I_LSL |
Alpha_context.Script.I_LSR) as name) [] _,
Script_typed_ir.Item_t ta (Script_typed_ir.Item_t tb _ _) _), _) =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (serialize_ty_for_error ctxt ta))
(fun function_parameter =>
let '(ta, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (serialize_ty_for_error ctxt tb))
(fun function_parameter =>
let '(tb, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value))
|
((Micheline.Prim loc
((Alpha_context.Script.I_NEG | Alpha_context.Script.I_ABS |
Alpha_context.Script.I_NOT | Alpha_context.Script.I_CONCAT |
Alpha_context.Script.I_SIZE | Alpha_context.Script.I_EQ |
Alpha_context.Script.I_NEQ | Alpha_context.Script.I_LT |
Alpha_context.Script.I_GT | Alpha_context.Script.I_LE |
Alpha_context.Script.I_GE) as name) [] _,
Script_typed_ir.Item_t __t_value _ _), _) =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(serialize_ty_for_error ctxt __t_value))
(fun function_parameter =>
let '(__t_value, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value)
|
((Micheline.Prim loc
((Alpha_context.Script.I_UPDATE | Alpha_context.Script.I_SLICE) as
name) [] _, stack), _) =>
Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value)
|
((Micheline.Prim loc Alpha_context.Script.I_CREATE_CONTRACT _ _, stack),
_) =>
Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value)
|
((Micheline.Prim loc Alpha_context.Script.I_CREATE_ACCOUNT [] _, stack),
_) =>
Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value)
|
((Micheline.Prim loc Alpha_context.Script.I_TRANSFER_TOKENS [] _, stack),
_) =>
Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value)
|
((Micheline.Prim loc
((Alpha_context.Script.I_DROP | Alpha_context.Script.I_DUP |
Alpha_context.Script.I_CAR | Alpha_context.Script.I_CDR |
Alpha_context.Script.I_SOME | Alpha_context.Script.I_BLAKE2B |
Alpha_context.Script.I_SHA256 | Alpha_context.Script.I_SHA512 |
Alpha_context.Script.I_DIP | Alpha_context.Script.I_IF_NONE |
Alpha_context.Script.I_LEFT | Alpha_context.Script.I_RIGHT |
Alpha_context.Script.I_IF_LEFT | Alpha_context.Script.I_IF |
Alpha_context.Script.I_LOOP | Alpha_context.Script.I_IF_CONS |
Alpha_context.Script.I_IMPLICIT_ACCOUNT | Alpha_context.Script.I_NEG |
Alpha_context.Script.I_ABS | Alpha_context.Script.I_INT |
Alpha_context.Script.I_NOT | Alpha_context.Script.I_HASH_KEY |
Alpha_context.Script.I_EQ | Alpha_context.Script.I_NEQ |
Alpha_context.Script.I_LT | Alpha_context.Script.I_GT |
Alpha_context.Script.I_LE | Alpha_context.Script.I_GE) as name) _ _,
stack), _) =>
Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value)
|
((Micheline.Prim loc
((Alpha_context.Script.I_SWAP | Alpha_context.Script.I_PAIR |
Alpha_context.Script.I_CONS | Alpha_context.Script.I_GET |
Alpha_context.Script.I_MEM | Alpha_context.Script.I_EXEC |
Alpha_context.Script.I_CHECK_SIGNATURE | Alpha_context.Script.I_ADD |
Alpha_context.Script.I_SUB | Alpha_context.Script.I_MUL |
Alpha_context.Script.I_EDIV | Alpha_context.Script.I_AND |
Alpha_context.Script.I_OR | Alpha_context.Script.I_XOR |
Alpha_context.Script.I_LSL | Alpha_context.Script.I_LSR) as name) _ _,
stack), _) =>
Error_monad.op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
Error_monad.fail extensible_type_value)
| ((expr, _), _) =>
Pervasives.op_atat Error_monad.fail
(unexpected expr [ Script_tc_errors.Seq_kind ]
Script_tc_errors.Instr_namespace
[
Alpha_context.Script.I_DROP;
Alpha_context.Script.I_DUP;
Alpha_context.Script.I_DIG;
Alpha_context.Script.I_DUG;
Alpha_context.Script.I_SWAP;
Alpha_context.Script.I_SOME;
Alpha_context.Script.I_UNIT;
Alpha_context.Script.I_PAIR;
Alpha_context.Script.I_CAR;
Alpha_context.Script.I_CDR;
Alpha_context.Script.I_CONS;
Alpha_context.Script.I_MEM;
Alpha_context.Script.I_UPDATE;
Alpha_context.Script.I_MAP;
Alpha_context.Script.I_ITER;
Alpha_context.Script.I_GET;
Alpha_context.Script.I_EXEC;
Alpha_context.Script.I_FAILWITH;
Alpha_context.Script.I_SIZE;
Alpha_context.Script.I_CONCAT;
Alpha_context.Script.I_ADD;
Alpha_context.Script.I_SUB;
Alpha_context.Script.I_MUL;
Alpha_context.Script.I_EDIV;
Alpha_context.Script.I_OR;
Alpha_context.Script.I_AND;
Alpha_context.Script.I_XOR;
Alpha_context.Script.I_NOT;
Alpha_context.Script.I_ABS;
Alpha_context.Script.I_INT;
Alpha_context.Script.I_NEG;
Alpha_context.Script.I_LSL;
Alpha_context.Script.I_LSR;
Alpha_context.Script.I_COMPARE;
Alpha_context.Script.I_EQ;
Alpha_context.Script.I_NEQ;
Alpha_context.Script.I_LT;
Alpha_context.Script.I_GT;
Alpha_context.Script.I_LE;
Alpha_context.Script.I_GE;
Alpha_context.Script.I_TRANSFER_TOKENS;
Alpha_context.Script.I_CREATE_ACCOUNT;
Alpha_context.Script.I_CREATE_CONTRACT;
Alpha_context.Script.I_NOW;
Alpha_context.Script.I_AMOUNT;
Alpha_context.Script.I_BALANCE;
Alpha_context.Script.I_IMPLICIT_ACCOUNT;
Alpha_context.Script.I_CHECK_SIGNATURE;
Alpha_context.Script.I_BLAKE2B;
Alpha_context.Script.I_SHA256;
Alpha_context.Script.I_SHA512;
Alpha_context.Script.I_HASH_KEY;
Alpha_context.Script.I_STEPS_TO_QUOTA;
Alpha_context.Script.I_PUSH;
Alpha_context.Script.I_NONE;
Alpha_context.Script.I_LEFT;
Alpha_context.Script.I_RIGHT;
Alpha_context.Script.I_NIL;
Alpha_context.Script.I_EMPTY_SET;
Alpha_context.Script.I_DIP;
Alpha_context.Script.I_LOOP;
Alpha_context.Script.I_IF_NONE;
Alpha_context.Script.I_IF_LEFT;
Alpha_context.Script.I_IF_CONS;
Alpha_context.Script.I_EMPTY_MAP;
Alpha_context.Script.I_IF;
Alpha_context.Script.I_SOURCE;
Alpha_context.Script.I_SENDER;
Alpha_context.Script.I_SELF;
Alpha_context.Script.I_LAMBDA
])
end)
with parse_contract {arg : Set}
(legacy : bool) (ctxt : Alpha_context.context)
(loc : Alpha_context.Script.location) (arg : Script_typed_ir.ty arg)
(contract : Alpha_context.Contract.t) (entrypoint : string) {struct legacy}
: Lwt.t
(Error_monad.tzresult
(Alpha_context.context * Script_typed_ir.typed_contract arg)) :=
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.contract_exists))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(Alpha_context.Contract.__exists ctxt contract)
(fun function_parameter =>
match function_parameter with
| false => Error_monad.fail extensible_type_value
| true =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.get_script))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat (Error_monad.trace extensible_type_value)
(Alpha_context.Contract.get_script_code ctxt contract))
(fun function_parameter =>
let '(ctxt, code) := function_parameter in
match code with
| None =>
Lwt.__return
(Error_monad.op_gtgtquestion
(ty_eq ctxt arg (Script_typed_ir.Unit_t None))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
match entrypoint with
| "default" =>
let contract := (arg, (contract, entrypoint)) in
Error_monad.ok (ctxt, contract)
| entrypoint =>
Error_monad.__error_value extensible_type_value
end))
| Some code =>
Error_monad.op_gtgteqquestion
(Alpha_context.Script.force_decode ctxt code)
(fun function_parameter =>
let '(code, ctxt) := function_parameter in
Lwt.__return
(Error_monad.op_gtgtquestion
(parse_toplevel true code)
(fun function_parameter =>
let '(arg_type, _, _, root_name) :=
function_parameter in
Error_monad.op_gtgtquestion
(parse_parameter_ty ctxt true arg_type)
(fun function_parameter =>
let '(Ex_ty targ, ctxt) :=
function_parameter in
let __return
(ctxt : Alpha_context.context)
(targ : Script_typed_ir.ty arg)
(entrypoint : string)
: Error_monad.tzresult
(Alpha_context.context *
Script_typed_ir.typed_contract arg) :=
Error_monad.op_gtgtquestion
(merge_types legacy ctxt loc targ arg)
(fun function_parameter =>
let '(arg, ctxt) := function_parameter
in
let contract :=
(arg, (contract, entrypoint)) in
Error_monad.ok (ctxt, contract)) in
Error_monad.op_gtgtquestion
(find_entrypoint_for_type targ arg
root_name entrypoint ctxt)
(fun function_parameter =>
let '(ctxt, entrypoint, targ) :=
function_parameter in
Error_monad.op_gtgtquestion
(merge_types legacy ctxt loc targ arg)
(fun function_parameter =>
let '(targ, ctxt) :=
function_parameter in
__return ctxt targ entrypoint))))))
end))
end))
with parse_contract_for_script {arg : Set}
(legacy : bool) (ctxt : Alpha_context.context)
(loc : Alpha_context.Script.location) (arg : Script_typed_ir.ty arg)
(contract : Alpha_context.Contract.t) (entrypoint : string) {struct legacy}
: Lwt.t
(Error_monad.tzresult
(Alpha_context.context * option (Script_typed_ir.typed_contract arg))) :=
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.contract_exists))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(Alpha_context.Contract.__exists ctxt contract)
(fun function_parameter =>
match function_parameter with
| false => Error_monad.__return (ctxt, None)
| true =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.get_script))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(Pervasives.op_atat (Error_monad.trace extensible_type_value)
(Alpha_context.Contract.get_script_code ctxt contract))
(fun function_parameter =>
let '(ctxt, code) := function_parameter in
match code with
| None =>
match entrypoint with
| "default" =>
Lwt.__return
match ty_eq ctxt arg (Script_typed_ir.Unit_t None)
with
| Pervasives.Ok (Eq, ctxt) =>
let contract := (arg, (contract, entrypoint)) in
Error_monad.ok (ctxt, (Some contract))
| Pervasives.Error _ =>
Error_monad.op_gtgtquestion
(Alpha_context.Gas.consume ctxt
Typecheck_costs.cycle)
(fun ctxt => Error_monad.ok (ctxt, None))
end
| _ => Error_monad.__return (ctxt, None)
end
| Some code =>
Error_monad.op_gtgteqquestion
(Alpha_context.Script.force_decode ctxt code)
(fun function_parameter =>
let '(code, ctxt) := function_parameter in
Lwt.__return
match parse_toplevel true code with
| Pervasives.Error _ =>
Error_monad.__error_value extensible_type_value
| Pervasives.Ok (arg_type, _, _, root_name) =>
match parse_parameter_ty ctxt true arg_type with
| Pervasives.Error _ =>
Error_monad.__error_value extensible_type_value
| Pervasives.Ok (Ex_ty targ, ctxt) =>
match
Error_monad.op_gtgtquestion
(find_entrypoint_for_type targ arg root_name
entrypoint ctxt)
(fun function_parameter =>
let '(ctxt, entrypoint, targ) :=
function_parameter in
Error_monad.op_gtgtquestion
(merge_types legacy ctxt loc targ arg)
(fun function_parameter =>
let '(targ, ctxt) :=
function_parameter in
Error_monad.op_gtgtquestion
(merge_types legacy ctxt loc targ
arg)
(fun function_parameter =>
let '(arg, ctxt) :=
function_parameter in
let contract :=
(arg, (contract, entrypoint)) in
Error_monad.ok
(ctxt, (Some contract))))) with
| Pervasives.Ok res => Error_monad.ok res
| Pervasives.Error _ =>
Error_monad.op_gtgtquestion
(ty_eq ctxt targ targ)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Error_monad.op_gtgtquestion
(merge_types legacy ctxt loc targ targ)
(fun function_parameter =>
let '(_, ctxt) := function_parameter
in
Error_monad.ok (ctxt, None)))
end
end
end)
end))
end))
with parse_toplevel (legacy : bool) (toplevel : Alpha_context.Script.expr)
{struct legacy}
: Error_monad.tzresult
(Alpha_context.Script.node * Alpha_context.Script.node *
Alpha_context.Script.node * option string) :=
Pervasives.op_atat (Error_monad.record_trace extensible_type_value)
match Micheline.root toplevel with
| Micheline.Int loc _ => Error_monad.__error_value extensible_type_value
| Micheline.String loc _ => Error_monad.__error_value extensible_type_value
| Micheline.Bytes loc _ => Error_monad.__error_value extensible_type_value
| Micheline.Prim loc _ _ _ =>
Error_monad.__error_value extensible_type_value
| Micheline.Seq _ fields =>
let fix find_fields
(p :
option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim * Alpha_context.Script.location *
Micheline.annot))
(s :
option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim * Alpha_context.Script.location *
Micheline.annot))
(c :
option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim * Alpha_context.Script.location *
Micheline.annot))
(fields :
list
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim)) {struct p}
: Error_monad.tzresult
(option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim * Alpha_context.Script.location *
Micheline.annot) *
option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim * Alpha_context.Script.location *
Micheline.annot) *
option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim * Alpha_context.Script.location *
Micheline.annot)) :=
match fields with
| [] => Error_monad.ok (p, s, c)
| cons (Micheline.Int loc _) _ =>
Error_monad.__error_value extensible_type_value
| cons (Micheline.String loc _) _ =>
Error_monad.__error_value extensible_type_value
| cons (Micheline.Bytes loc _) _ =>
Error_monad.__error_value extensible_type_value
| cons (Micheline.Seq loc _) _ =>
Error_monad.__error_value extensible_type_value
|
cons
(Micheline.Prim loc Alpha_context.Script.K_parameter (cons arg [])
annot) rest =>
match p with
| None => find_fields (Some (arg, loc, annot)) s c rest
| Some _ => Error_monad.__error_value extensible_type_value
end
|
cons
(Micheline.Prim loc Alpha_context.Script.K_storage (cons arg [])
annot) rest =>
match s with
| None => find_fields p (Some (arg, loc, annot)) c rest
| Some _ => Error_monad.__error_value extensible_type_value
end
|
cons
(Micheline.Prim loc Alpha_context.Script.K_code (cons arg []) annot)
rest =>
match c with
| None => find_fields p s (Some (arg, loc, annot)) rest
| Some _ => Error_monad.__error_value extensible_type_value
end
|
cons
(Micheline.Prim loc
((Alpha_context.Script.K_parameter |
Alpha_context.Script.K_storage | Alpha_context.Script.K_code) as
name) args _) _ =>
Error_monad.__error_value extensible_type_value
| cons (Micheline.Prim loc name _ _) _ =>
let allowed :=
[
Alpha_context.Script.K_parameter;
Alpha_context.Script.K_storage;
Alpha_context.Script.K_code
] in
Error_monad.__error_value extensible_type_value
end in
Error_monad.op_gtgtquestion (find_fields None None None fields)
(fun function_parameter =>
match function_parameter with
| (None, _, _) => Error_monad.__error_value extensible_type_value
| (Some _, None, _) => Error_monad.__error_value extensible_type_value
| (Some _, Some _, None) =>
Error_monad.__error_value extensible_type_value
|
(Some (p, ploc, pannot), Some (s, sloc, sannot),
Some (c, cloc, carrot)) =>
let maybe_root_name :=
Error_monad.op_gtgtquestion
(Script_ir_annot.extract_field_annot p)
(fun function_parameter =>
let '(p, root_name) := function_parameter in
match root_name with
| Some (Field_annot root_name) =>
Error_monad.ok (p, pannot, (Some root_name))
| None =>
match
(pannot,
match pannot with
| cons single [] =>
Pervasives.op_andand
((|Compare.Int|).(Compare.S.op_gt)
(String.length single) 0)
((|Compare.Char|).(Compare.S.op_eq)
(String.get single 0) "%" % char)
| _ => false
end) with
| (cons single [], true) =>
Error_monad.ok
(p, [],
(Some
(String.sub single 1
(Pervasives.op_minus (String.length single) 1))))
| (_, _) => Error_monad.ok (p, pannot, None)
end
end) in
if legacy then
let '(p, root_name) :=
match maybe_root_name with
| Pervasives.Ok (p, _, root_name) => (p, root_name)
| Pervasives.Error _ => (p, None)
end in
Error_monad.ok (p, s, c, root_name)
else
Error_monad.op_gtgtquestion maybe_root_name
(fun function_parameter =>
let '(p, pannot, root_name) := function_parameter in
Error_monad.op_gtgtquestion
(Script_ir_annot.error_unexpected_annot ploc pannot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgtquestion
(Script_ir_annot.error_unexpected_annot cloc carrot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgtquestion
(Script_ir_annot.error_unexpected_annot sloc sannot)
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.ok (p, s, c, root_name)))))
end)
end.
Definition parse_script
(type_logger : option type_logger) (ctxt : Alpha_context.context)
(legacy : bool) (function_parameter : Alpha_context.Script.t)
: Lwt.t (Error_monad.tzresult (ex_script * Alpha_context.context)) :=
let '{|
Alpha_context.Script.t.code := code;
Alpha_context.Script.t.storage := storage
|} := function_parameter in
Error_monad.op_gtgteqquestion (Alpha_context.Script.force_decode ctxt code)
(fun function_parameter =>
let '(code, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Alpha_context.Script.force_decode ctxt storage)
(fun function_parameter =>
let '(storage, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (parse_toplevel legacy code))
(fun function_parameter =>
let '(arg_type, storage_type, code_field, root_name) :=
function_parameter in
Error_monad.op_gtgteqquestion
(Error_monad.trace extensible_type_value
(Lwt.__return (parse_parameter_ty ctxt legacy arg_type)))
(fun function_parameter =>
let '(Ex_ty arg_type, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(if legacy then
Error_monad.__return tt
else
Lwt.__return (well_formed_entrypoints arg_type root_name))
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Error_monad.trace extensible_type_value
(Lwt.__return
(parse_storage_ty ctxt legacy storage_type)))
(fun function_parameter =>
let '(Ex_ty storage_type, ctxt) := function_parameter
in
let arg_annot :=
Script_ir_annot.default_annot
Script_ir_annot.default_param_annot
(Script_ir_annot.type_to_var_annot
(name_of_ty arg_type)) in
let storage_annot :=
Script_ir_annot.default_annot
Script_ir_annot.default_storage_annot
(Script_ir_annot.type_to_var_annot
(name_of_ty storage_type)) in
let arg_type_full :=
Script_typed_ir.Pair_t (arg_type, None, arg_annot)
(storage_type, None, storage_annot) None
(Pervasives.op_pipepipe (has_big_map arg_type)
(has_big_map storage_type)) in
let ret_type_full :=
Script_typed_ir.Pair_t
((Script_typed_ir.List_t
(Script_typed_ir.Operation_t None) None false),
None, None) (storage_type, None, None) None
(has_big_map storage_type) in
Error_monad.op_gtgteqquestion
(Error_monad.trace_eval
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgtpipequestion
(Pervasives.op_atat Lwt.__return
(serialize_ty_for_error ctxt storage_type))
(fun function_parameter =>
let '(storage_type, _ctxt) :=
function_parameter in
extensible_type_value))
(parse_data type_logger ctxt legacy storage_type
(Micheline.root storage)))
(fun function_parameter =>
let '(storage, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Error_monad.trace extensible_type_value
(parse_returning type_logger
(Toplevel
{|
tc_context.Toplevel.storage_type :=
storage_type; tc_context.Toplevel.param_type :=
arg_type; tc_context.Toplevel.root_name :=
root_name; tc_context.Toplevel.legacy_create_contract_literal :=
false |}) ctxt legacy
(arg_type_full, None) ret_type_full
code_field))
(fun function_parameter =>
let '(code, ctxt) := function_parameter in
Error_monad.__return
((Ex_script
{|
Script_typed_ir.script.code := code; Script_typed_ir.script.arg_type :=
arg_type; Script_typed_ir.script.storage :=
storage; Script_typed_ir.script.storage_type :=
storage_type; Script_typed_ir.script.root_name :=
root_name |}), ctxt))))))))).
Definition typecheck_code
(ctxt : Alpha_context.context) (code : Alpha_context.Script.expr)
: Lwt.t
(Error_monad.tzresult (Script_tc_errors.type_map * Alpha_context.context)) :=
let legacy := false in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return (parse_toplevel legacy code))
(fun function_parameter =>
let '(arg_type, storage_type, code_field, root_name) := function_parameter
in
let type_map := Pervasives.__ref_value [] in
Error_monad.op_gtgteqquestion
(Error_monad.trace extensible_type_value
(Lwt.__return (parse_parameter_ty ctxt legacy arg_type)))
(fun function_parameter =>
let '(Ex_ty arg_type, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(if legacy then
Error_monad.__return tt
else
Lwt.__return (well_formed_entrypoints arg_type root_name))
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgteqquestion
(Error_monad.trace extensible_type_value
(Lwt.__return (parse_storage_ty ctxt legacy storage_type)))
(fun function_parameter =>
let '(Ex_ty storage_type, ctxt) := function_parameter in
let arg_annot :=
Script_ir_annot.default_annot
Script_ir_annot.default_param_annot
(Script_ir_annot.type_to_var_annot (name_of_ty arg_type))
in
let storage_annot :=
Script_ir_annot.default_annot
Script_ir_annot.default_storage_annot
(Script_ir_annot.type_to_var_annot
(name_of_ty storage_type)) in
let arg_type_full :=
Script_typed_ir.Pair_t (arg_type, None, arg_annot)
(storage_type, None, storage_annot) None
(Pervasives.op_pipepipe (has_big_map arg_type)
(has_big_map storage_type)) in
let ret_type_full :=
Script_typed_ir.Pair_t
((Script_typed_ir.List_t
(Script_typed_ir.Operation_t None) None false), None,
None) (storage_type, None, None) None
(has_big_map storage_type) in
let __result_value :=
parse_returning
(Some
(fun loc =>
fun bef =>
fun aft =>
Pervasives.op_coloneq type_map
(cons (loc, (bef, aft))
(Pervasives.op_exclamation type_map))))
(Toplevel
{|
tc_context.Toplevel.storage_type := storage_type; tc_context.Toplevel.param_type :=
arg_type; tc_context.Toplevel.root_name := root_name; tc_context.Toplevel.legacy_create_contract_literal :=
false |}) ctxt legacy (arg_type_full, None)
ret_type_full code_field in
Error_monad.op_gtgteqquestion
(Error_monad.trace extensible_type_value __result_value)
(fun function_parameter =>
let '(Script_typed_ir.Lam _ _, ctxt) := function_parameter
in
Error_monad.__return
((Pervasives.op_exclamation type_map), ctxt)))))).
Definition typecheck_data
(type_logger : option type_logger) (ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.expr * Alpha_context.Script.expr)
: Lwt.t (Error_monad.tzresult Alpha_context.context) :=
let '(data, exp_ty) := function_parameter in
let legacy := false in
Error_monad.op_gtgteqquestion
(Error_monad.trace extensible_type_value
(Pervasives.op_atat Lwt.__return
(parse_packable_ty ctxt legacy (Micheline.root exp_ty))))
(fun function_parameter =>
let '(Ex_ty exp_ty, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Error_monad.trace_eval
(fun function_parameter =>
let '_ := function_parameter in
Error_monad.op_gtgtpipequestion
(Pervasives.op_atat Lwt.__return
(serialize_ty_for_error ctxt exp_ty))
(fun function_parameter =>
let '(exp_ty, _ctxt) := function_parameter in
extensible_type_value))
(parse_data type_logger ctxt legacy exp_ty (Micheline.root data)))
(fun function_parameter =>
let '(_, ctxt) := function_parameter in
Error_monad.__return ctxt)).
Definition Entrypoints_map :=
Map.Make
(existT _ _
{|
Compare.COMPARABLE.compare := String.compare
|}).
Definition list_entrypoints {A : Set}
(full : Script_typed_ir.ty A) (ctxt : Alpha_context.context)
(root_name : option (|Entrypoints_map|).(S.MAP.key))
: Error_monad.tzresult
(list (list Alpha_context.Script.prim) *
(|Entrypoints_map|).(S.MAP.t)
(list Alpha_context.Script.prim * Alpha_context.Script.node)) :=
let merge {B C : Set}
(path : list B)
(annot : option (* `Field_annot *) (|Entrypoints_map|).(S.MAP.key))
(ty : Script_typed_ir.ty C) (reachable : bool)
(function_parameter :
list (list B) *
(|Entrypoints_map|).(S.MAP.t) (list B * Alpha_context.Script.node))
: Error_monad.tzresult
(list (list B) *
(|Entrypoints_map|).(S.MAP.t) (list B * Alpha_context.Script.node)) :=
let '(unreachables, all) as acc := function_parameter in
match annot with
| None | Some (Field_annot "") =>
Pervasives.op_atat Error_monad.ok
(if reachable then
acc
else
match ty with
| Script_typed_ir.Union_t _ _ _ _ => acc
| _ => ((cons (List.rev path) unreachables), all)
end)
| Some (Field_annot name) =>
if (|Compare.Int|).(Compare.S.op_gt) (String.length name) 31 then
Error_monad.ok ((cons (List.rev path) unreachables), all)
else
if (|Entrypoints_map|).(S.MAP.mem) name all then
Error_monad.ok ((cons (List.rev path) unreachables), all)
else
Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt ty)
(fun function_parameter =>
let '(unparsed_ty, _) := function_parameter in
Error_monad.ok
(unreachables,
((|Entrypoints_map|).(S.MAP.add) name
((List.rev path), unparsed_ty) all)))
end in
let fix fold_tree {t : Set}
(__t_value : Script_typed_ir.ty t) (path : list Alpha_context.Script.prim)
(reachable : bool)
(acc :
list (list Alpha_context.Script.prim) *
(|Entrypoints_map|).(S.MAP.t)
(list Alpha_context.Script.prim * Alpha_context.Script.node))
{struct __t_value}
: Error_monad.tzresult
(list (list Alpha_context.Script.prim) *
(|Entrypoints_map|).(S.MAP.t)
(list Alpha_context.Script.prim * Alpha_context.Script.node)) :=
match __t_value with
| Script_typed_ir.Union_t (tl, al) (tr, ar) _ _ =>
Error_monad.op_gtgtquestion
(merge (cons Alpha_context.Script.D_Left path) al tl reachable acc)
(fun acc =>
Error_monad.op_gtgtquestion
(merge (cons Alpha_context.Script.D_Right path) ar tr reachable acc)
(fun acc =>
Error_monad.op_gtgtquestion
(fold_tree tl (cons Alpha_context.Script.D_Left path)
match al with
| Some _ => true
| None => reachable
end acc)
(fun acc =>
fold_tree tr (cons Alpha_context.Script.D_Right path)
match ar with
| Some _ => true
| None => reachable
end acc)))
| _ => Error_monad.ok acc
end in
Error_monad.op_gtgtquestion (unparse_ty_no_lwt ctxt full)
(fun function_parameter =>
let '(unparsed_full, _) := function_parameter in
let '(init, reachable) :=
match root_name with
| None | Some "" => ((|Entrypoints_map|).(S.MAP.empty), false)
| Some name =>
(((|Entrypoints_map|).(S.MAP.singleton) name ([], unparsed_full)),
true)
end in
fold_tree full [] reachable ([], init)).
Fixpoint unparse_data {a : Set}
(ctxt : Alpha_context.context) (mode : unparsing_mode)
(ty : Script_typed_ir.ty a) (a : a) {struct ctxt}
: Lwt.t
(Error_monad.tzresult (Alpha_context.Script.node * Alpha_context.context)) :=
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.cycle))
(fun ctxt =>
match (ty, a) with
| (Script_typed_ir.Unit_t _, _) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Unparse_costs.__unit_value))
(fun ctxt =>
Error_monad.__return
((Micheline.Prim (-1) Alpha_context.Script.D_Unit [] []), ctxt))
| (Script_typed_ir.Int_t _, v) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt (Unparse_costs.int v)))
(fun ctxt =>
Error_monad.__return
((Micheline.Int (-1) (Alpha_context.Script_int.to_zint v)), ctxt))
| (Script_typed_ir.Nat_t _, v) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt (Unparse_costs.int v)))
(fun ctxt =>
Error_monad.__return
((Micheline.Int (-1) (Alpha_context.Script_int.to_zint v)), ctxt))
| (Script_typed_ir.String_t _, s) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt (Unparse_costs.__string_value s)))
(fun ctxt => Error_monad.__return ((Micheline.String (-1) s), ctxt))
| (Script_typed_ir.Bytes_t _, s) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt (Unparse_costs.__bytes_value s)))
(fun ctxt => Error_monad.__return ((Micheline.Bytes (-1) s), ctxt))
| (Script_typed_ir.Bool_t _, true) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Unparse_costs.__bool_value))
(fun ctxt =>
Error_monad.__return
((Micheline.Prim (-1) Alpha_context.Script.D_True [] []), ctxt))
| (Script_typed_ir.Bool_t _, false) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Unparse_costs.__bool_value))
(fun ctxt =>
Error_monad.__return
((Micheline.Prim (-1) Alpha_context.Script.D_False [] []), ctxt))
| (Script_typed_ir.Timestamp_t _, __t_value) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt (Unparse_costs.timestamp __t_value)))
(fun ctxt =>
match mode with
| Optimized =>
Error_monad.__return
((Micheline.Int (-1)
(Alpha_context.Script_timestamp.to_zint __t_value)), ctxt)
| Readable =>
match Alpha_context.Script_timestamp.to_notation __t_value with
| None =>
Error_monad.__return
((Micheline.Int (-1)
(Alpha_context.Script_timestamp.to_zint __t_value)), ctxt)
| Some s => Error_monad.__return ((Micheline.String (-1) s), ctxt)
end
end)
| (Script_typed_ir.Address_t _, (c, entrypoint)) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.contract))
(fun ctxt =>
match mode with
| Optimized =>
let entrypoint :=
match entrypoint with
| "default" => ""
| name => name
end in
let __bytes_value :=
Data_encoding.Binary.to_bytes_exn
(Data_encoding.tup2 Alpha_context.Contract.encoding
Data_encoding.__Variable.__string_value) (c, entrypoint) in
Error_monad.__return ((Micheline.Bytes (-1) __bytes_value), ctxt)
| Readable =>
let notation :=
match entrypoint with
| "default" => Alpha_context.Contract.to_b58check c
| entrypoint =>
Pervasives.op_caret (Alpha_context.Contract.to_b58check c)
(Pervasives.op_caret "%" entrypoint)
end in
Error_monad.__return ((Micheline.String (-1) notation), ctxt)
end)
| (Script_typed_ir.Contract_t _ _, (_, (c, entrypoint))) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.contract))
(fun ctxt =>
match mode with
| Optimized =>
let entrypoint :=
match entrypoint with
| "default" => ""
| name => name
end in
let __bytes_value :=
Data_encoding.Binary.to_bytes_exn
(Data_encoding.tup2 Alpha_context.Contract.encoding
Data_encoding.__Variable.__string_value) (c, entrypoint) in
Error_monad.__return ((Micheline.Bytes (-1) __bytes_value), ctxt)
| Readable =>
let notation :=
match entrypoint with
| "default" => Alpha_context.Contract.to_b58check c
| entrypoint =>
Pervasives.op_caret (Alpha_context.Contract.to_b58check c)
(Pervasives.op_caret "%" entrypoint)
end in
Error_monad.__return ((Micheline.String (-1) notation), ctxt)
end)
| (Script_typed_ir.Signature_t _, s) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.signature))
(fun ctxt =>
match mode with
| Optimized =>
let __bytes_value :=
Data_encoding.Binary.to_bytes_exn Signature.encoding s in
Error_monad.__return ((Micheline.Bytes (-1) __bytes_value), ctxt)
| Readable =>
Error_monad.__return
((Micheline.String (-1) (Signature.to_b58check s)), ctxt)
end)
| (Script_typed_ir.Mutez_t _, v) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.tez))
(fun ctxt =>
Error_monad.__return
((Micheline.Int (-1) (Z.of_int64 (Alpha_context.Tez.to_mutez v))),
ctxt))
| (Script_typed_ir.Key_t _, k) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.key))
(fun ctxt =>
match mode with
| Optimized =>
let __bytes_value :=
Data_encoding.Binary.to_bytes_exn
(|Signature.Public_key|).(S.SPublic_key.encoding) k in
Error_monad.__return ((Micheline.Bytes (-1) __bytes_value), ctxt)
| Readable =>
Error_monad.__return
((Micheline.String (-1)
((|Signature.Public_key|).(S.SPublic_key.to_b58check) k)),
ctxt)
end)
| (Script_typed_ir.Key_hash_t _, k) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.key_hash))
(fun ctxt =>
match mode with
| Optimized =>
let __bytes_value :=
Data_encoding.Binary.to_bytes_exn
(|Signature.Public_key_hash|).(S.SPublic_key_hash.encoding) k
in
Error_monad.__return ((Micheline.Bytes (-1) __bytes_value), ctxt)
| Readable =>
Error_monad.__return
((Micheline.String (-1)
((|Signature.Public_key_hash|).(S.SPublic_key_hash.to_b58check)
k)), ctxt)
end)
| (Script_typed_ir.Operation_t _, (op, _big_map_diff)) =>
let __bytes_value :=
Data_encoding.Binary.to_bytes_exn
Alpha_context.Operation.internal_operation_encoding op in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt
(Unparse_costs.operation __bytes_value)))
(fun ctxt =>
Error_monad.__return ((Micheline.Bytes (-1) __bytes_value), ctxt))
| (Script_typed_ir.Chain_id_t _, chain_id) =>
let __bytes_value :=
Data_encoding.Binary.to_bytes_exn (|Chain_id|).(S.HASH.encoding)
chain_id in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt
(Unparse_costs.chain_id __bytes_value)))
(fun ctxt =>
Error_monad.__return ((Micheline.Bytes (-1) __bytes_value), ctxt))
| (Script_typed_ir.Pair_t (tl, _, _) (tr, _, _) _ _, (l, r)) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.pair))
(fun ctxt =>
Error_monad.op_gtgteqquestion (unparse_data ctxt mode tl l)
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (unparse_data ctxt mode tr r)
(fun function_parameter =>
let '(r, ctxt) := function_parameter in
Error_monad.__return
((Micheline.Prim (-1) Alpha_context.Script.D_Pair [ l; r ]
[]), ctxt))))
| (Script_typed_ir.Union_t (tl, _) _ _ _, Script_typed_ir.L l) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.union))
(fun ctxt =>
Error_monad.op_gtgteqquestion (unparse_data ctxt mode tl l)
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
Error_monad.__return
((Micheline.Prim (-1) Alpha_context.Script.D_Left [ l ] []),
ctxt)))
| (Script_typed_ir.Union_t _ (tr, _) _ _, Script_typed_ir.R r) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.union))
(fun ctxt =>
Error_monad.op_gtgteqquestion (unparse_data ctxt mode tr r)
(fun function_parameter =>
let '(r, ctxt) := function_parameter in
Error_monad.__return
((Micheline.Prim (-1) Alpha_context.Script.D_Right [ r ] []),
ctxt)))
| (Script_typed_ir.Option_t __t_value _ _, Some v) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.some))
(fun ctxt =>
Error_monad.op_gtgteqquestion (unparse_data ctxt mode __t_value v)
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
Error_monad.__return
((Micheline.Prim (-1) Alpha_context.Script.D_Some [ v ] []),
ctxt)))
| (Script_typed_ir.Option_t _ _ _, None) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Unparse_costs.none))
(fun ctxt =>
Error_monad.__return
((Micheline.Prim (-1) Alpha_context.Script.D_None [] []), ctxt))
| (Script_typed_ir.List_t __t_value _ _, items) =>
Error_monad.op_gtgteqquestion
(Error_monad.fold_left_s
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
fun element =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Unparse_costs.list_element))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(unparse_data ctxt mode __t_value element)
(fun function_parameter =>
let '(unparsed, ctxt) := function_parameter in
Error_monad.__return ((cons unparsed l), ctxt))))
([], ctxt) items)
(fun function_parameter =>
let '(items, ctxt) := function_parameter in
Error_monad.__return ((Micheline.Seq (-1) (List.rev items)), ctxt))
| (Script_typed_ir.Set_t __t_value _, set) =>
let __t_value := ty_of_comparable_ty __t_value in
Error_monad.op_gtgteqquestion
(Error_monad.fold_left_s
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
fun item =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Unparse_costs.set_element))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(unparse_data ctxt mode __t_value item)
(fun function_parameter =>
let '(item, ctxt) := function_parameter in
Error_monad.__return ((cons item l), ctxt)))) ([], ctxt)
(set_fold (fun e => fun acc => cons e acc) set []))
(fun function_parameter =>
let '(items, ctxt) := function_parameter in
Error_monad.__return ((Micheline.Seq (-1) items), ctxt))
| (Script_typed_ir.Map_t kt vt _ _, map) =>
let kt := ty_of_comparable_ty kt in
Error_monad.op_gtgteqquestion
(Error_monad.fold_left_s
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
fun function_parameter =>
let '(k, v) := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Unparse_costs.map_element))
(fun ctxt =>
Error_monad.op_gtgteqquestion (unparse_data ctxt mode kt k)
(fun function_parameter =>
let '(key, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(unparse_data ctxt mode vt v)
(fun function_parameter =>
let '(value, ctxt) := function_parameter in
Error_monad.__return
((cons
(Micheline.Prim (-1) Alpha_context.Script.D_Elt
[ key; value ] []) l), ctxt))))) ([], ctxt)
(map_fold (fun k => fun v => fun acc => cons (k, v) acc) map []))
(fun function_parameter =>
let '(items, ctxt) := function_parameter in
Error_monad.__return ((Micheline.Seq (-1) items), ctxt))
|
(Script_typed_ir.Big_map_t kt vt _, {|
Script_typed_ir.big_map.id := None;
Script_typed_ir.big_map.diff := Diff
|}) =>
let kt := ty_of_comparable_ty kt in
Error_monad.op_gtgteqquestion
(Error_monad.fold_left_s
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
fun function_parameter =>
let '(k, v) := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Unparse_costs.map_element))
(fun ctxt =>
Error_monad.op_gtgteqquestion (unparse_data ctxt mode kt k)
(fun function_parameter =>
let '(key, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(unparse_data ctxt mode vt v)
(fun function_parameter =>
let '(value, ctxt) := function_parameter in
Error_monad.__return
((cons
(Micheline.Prim (-1) Alpha_context.Script.D_Elt
[ key; value ] []) l), ctxt))))) ([], ctxt)
((|Diff|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.fold)
(fun k =>
fun v =>
fun acc =>
match v with
| None => acc
| Some v => cons (k, v) acc
end)
(Pervasives.fst (|Diff|).(Script_typed_ir.Boxed_map.boxed)) []))
(fun function_parameter =>
let '(items, ctxt) := function_parameter in
Error_monad.__return ((Micheline.Seq (-1) items), ctxt))
|
(Script_typed_ir.Big_map_t _kt _kv _, {|
Script_typed_ir.big_map.id := Some id;
Script_typed_ir.big_map.diff := Diff
|}) =>
if
(|Compare.Int|).(Compare.S.op_eq)
((|Diff|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.cardinal)
(Pervasives.fst (|Diff|).(Script_typed_ir.Boxed_map.boxed))) 0
then
Error_monad.__return ((Micheline.Int (-1) id), ctxt)
else
(* ❌ Assert instruction is not handled. *)
assert false
| (Script_typed_ir.Lambda_t _ _ _, Script_typed_ir.Lam _ original_code) =>
unparse_code ctxt mode original_code
end)
with unparse_code (ctxt : Alpha_context.context) (mode : unparsing_mode)
{struct ctxt}
: Alpha_context.Script.node ->
Lwt.t
(Error_monad.tzresult
(Micheline.node Z Alpha_context.Script.prim * Alpha_context.context)) :=
let legacy := true in
fun function_parameter =>
match function_parameter with
|
Micheline.Prim loc Alpha_context.Script.I_PUSH (cons ty (cons data []))
annot =>
Error_monad.op_gtgteqquestion
(Lwt.__return (parse_packable_ty ctxt legacy ty))
(fun function_parameter =>
let '(Ex_ty __t_value, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(parse_data None ctxt legacy __t_value data)
(fun function_parameter =>
let '(data, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(unparse_data ctxt mode __t_value data)
(fun function_parameter =>
let '(data, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt
(Unparse_costs.prim_cost 2 annot)))
(fun ctxt =>
Error_monad.__return
((Micheline.Prim loc Alpha_context.Script.I_PUSH
[ ty; data ] annot), ctxt)))))
| Micheline.Seq loc items =>
Error_monad.op_gtgteqquestion
(Error_monad.fold_left_s
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
fun item =>
Error_monad.op_gtgteqquestion (unparse_code ctxt mode item)
(fun function_parameter =>
let '(item, ctxt) := function_parameter in
Error_monad.__return ((cons item l), ctxt))) ([], ctxt) items)
(fun function_parameter =>
let '(items, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt
(Unparse_costs.seq_cost (List.length items))))
(fun ctxt =>
Error_monad.__return ((Micheline.Seq loc (List.rev items)), ctxt)))
| Micheline.Prim loc prim items annot =>
Error_monad.op_gtgteqquestion
(Error_monad.fold_left_s
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
fun item =>
Error_monad.op_gtgteqquestion (unparse_code ctxt mode item)
(fun function_parameter =>
let '(item, ctxt) := function_parameter in
Error_monad.__return ((cons item l), ctxt))) ([], ctxt) items)
(fun function_parameter =>
let '(items, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)))
(fun ctxt =>
Error_monad.__return
((Micheline.Prim loc prim (List.rev items) annot), ctxt)))
| (Micheline.Int _ _ | Micheline.String _ _ | Micheline.Bytes _ _) as atom
=> Error_monad.__return (atom, ctxt)
end.
Definition unparse_script {A B : Set}
(ctxt : Alpha_context.context) (mode : unparsing_mode)
(function_parameter : Script_typed_ir.script A B)
: Lwt.t
(Error_monad.tzresult (Alpha_context.Script.t * Alpha_context.context)) :=
let '{|
Script_typed_ir.script.code := code;
Script_typed_ir.script.arg_type := arg_type;
Script_typed_ir.script.storage := storage;
Script_typed_ir.script.storage_type := storage_type;
Script_typed_ir.script.root_name := root_name
|} := function_parameter in
let 'Script_typed_ir.Lam _ original_code := code in
Error_monad.op_gtgteqquestion (unparse_code ctxt mode original_code)
(fun function_parameter =>
let '(code, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(unparse_data ctxt mode storage_type storage)
(fun function_parameter =>
let '(storage, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (unparse_ty ctxt arg_type)
(fun function_parameter =>
let '(arg_type, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (unparse_ty ctxt storage_type)
(fun function_parameter =>
let '(storage_type, ctxt) := function_parameter in
let arg_type :=
add_field_annot
(Option.map
(fun n =>
(* ❌ Variants not supported *)
(* ❌ `Field_annot *)
Field_annot n) root_name) None arg_type in
let code :=
Micheline.Seq (-1)
[
Micheline.Prim (-1) Alpha_context.Script.K_parameter
[ arg_type ] [];
Micheline.Prim (-1) Alpha_context.Script.K_storage
[ storage_type ] [];
Micheline.Prim (-1) Alpha_context.Script.K_code [ code ]
[]
] in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Error_monad.op_gtgtquestion
(Alpha_context.Gas.consume ctxt
(Unparse_costs.seq_cost 3))
(fun ctxt =>
Error_monad.op_gtgtquestion
(Alpha_context.Gas.consume ctxt
(Unparse_costs.prim_cost 1 []))
(fun ctxt =>
Error_monad.op_gtgtquestion
(Alpha_context.Gas.consume ctxt
(Unparse_costs.prim_cost 1 []))
(fun ctxt =>
Alpha_context.Gas.consume ctxt
(Unparse_costs.prim_cost 1 []))))))
(fun ctxt =>
Error_monad.__return
({|
Alpha_context.Script.t.code :=
Alpha_context.Script.__lazy_expr_value
(Micheline.strip_locations code); Alpha_context.Script.t.storage :=
Alpha_context.Script.__lazy_expr_value
(Micheline.strip_locations storage) |}, ctxt)))))).
Definition pack_data {A : Set}
(ctxt : Alpha_context.context) (typ : Script_typed_ir.ty A) (data : A)
: Lwt.t (Error_monad.tzresult (MBytes.t * Alpha_context.context)) :=
Error_monad.op_gtgteqquestion (unparse_data ctxt Optimized typ data)
(fun function_parameter =>
let '(unparsed, ctxt) := function_parameter in
let __bytes_value :=
Data_encoding.Binary.to_bytes_exn Alpha_context.Script.expr_encoding
(Micheline.strip_locations unparsed) in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Alpha_context.Gas.consume ctxt
(Alpha_context.Script.serialized_cost __bytes_value)))
(fun ctxt =>
let __bytes_value :=
MBytes.concat "" [ MBytes.of_string "\005"; __bytes_value ] in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Alpha_context.Gas.consume ctxt
(Alpha_context.Script.serialized_cost __bytes_value)))
(fun ctxt => Error_monad.__return (__bytes_value, ctxt)))).
Definition hash_data {A : Set}
(ctxt : Alpha_context.context) (typ : Script_typed_ir.ty A) (data : A)
: Lwt.t (Error_monad.tzresult (Script_expr_hash.t * Alpha_context.context)) :=
Error_monad.op_gtgteqquestion (pack_data ctxt typ data)
(fun function_parameter =>
let '(__bytes_value, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Pervasives.op_atat Lwt.__return
(Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Legacy.__hash_value __bytes_value
Script_expr_hash.size)))
(fun ctxt =>
Error_monad.__return
((Script_expr_hash.hash_bytes None [ __bytes_value ]), ctxt))).
Definition empty_big_map {A B : Set}
(tk : Script_typed_ir.comparable_ty A) (tv : Script_typed_ir.ty B)
: Script_typed_ir.big_map A B :=
{|
Script_typed_ir.big_map.id := None; Script_typed_ir.big_map.diff :=
empty_map tk; Script_typed_ir.big_map.key_type := ty_of_comparable_ty tk; Script_typed_ir.big_map.value_type :=
tv |}.
Definition big_map_mem {A B : Set}
(ctxt : Alpha_context.context) (key : A)
(function_parameter : Script_typed_ir.big_map A B)
: Lwt.t (Error_monad.tzresult (bool * Alpha_context.context)) :=
let '{|
Script_typed_ir.big_map.id := id;
Script_typed_ir.big_map.diff := diff;
Script_typed_ir.big_map.key_type := key_type
|} := function_parameter in
match ((map_get key diff), id) with
| (None, None) => Error_monad.__return (false, ctxt)
| (None, Some id) =>
Error_monad.op_gtgteqquestion (hash_data ctxt key_type key)
(fun function_parameter =>
let '(__hash_value, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Alpha_context.Big_map.mem ctxt id __hash_value)
(fun function_parameter =>
let '(ctxt, res) := function_parameter in
Error_monad.__return (res, ctxt)))
| (Some None, _) => Error_monad.__return (false, ctxt)
| (Some (Some _), _) => Error_monad.__return (true, ctxt)
end.
Definition big_map_get {A B : Set}
(ctxt : Alpha_context.context) (key : A)
(function_parameter : Script_typed_ir.big_map A B)
: Lwt.t (Error_monad.tzresult (option B * Alpha_context.context)) :=
let '{|
Script_typed_ir.big_map.id := id;
Script_typed_ir.big_map.diff := diff;
Script_typed_ir.big_map.key_type := key_type;
Script_typed_ir.big_map.value_type := value_type
|} := function_parameter in
match ((map_get key diff), id) with
| (Some x, _) => Error_monad.__return (x, ctxt)
| (None, None) => Error_monad.__return (None, ctxt)
| (None, Some id) =>
Error_monad.op_gtgteqquestion (hash_data ctxt key_type key)
(fun function_parameter =>
let '(__hash_value, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(Alpha_context.Big_map.get_opt ctxt id __hash_value)
(fun function_parameter =>
match function_parameter with
| (ctxt, None) => Error_monad.__return (None, ctxt)
| (ctxt, Some value) =>
Error_monad.op_gtgteqquestion
(parse_data None ctxt true value_type (Micheline.root value))
(fun function_parameter =>
let '(x, ctxt) := function_parameter in
Error_monad.__return ((Some x), ctxt))
end))
end.
Definition big_map_update {A B : Set}
(key : A) (value : option B)
(function_parameter : Script_typed_ir.big_map A B)
: Script_typed_ir.big_map A B :=
let '{| Script_typed_ir.big_map.diff := diff |} as map := function_parameter
in
Script_typed_ir.big_map.with_diff map (map_set key value diff).
Definition Ids :=
__Set.Make
(existT _ _
{|
Compare.COMPARABLE.compare := (|Compare.Z|).(Compare.S.compare)
|}).
Definition big_map_ids := (|Ids|).(S.SET.t).
Definition no_big_map_id : (|Ids|).(S.SET.t) := (|Ids|).(S.SET.empty).
Definition diff_of_big_map {A B : Set}
(ctxt : Alpha_context.context)
(fresh :
Alpha_context.context ->
Lwt.t
(Error_monad.tzresult (Alpha_context.context * Alpha_context.Big_map.id)))
(mode : unparsing_mode) (ids : (|Ids|).(S.SET.t))
(function_parameter : Script_typed_ir.big_map A B)
: Lwt.t
(Error_monad.tzresult
(list Alpha_context.Contract.big_map_diff_item * Alpha_context.Big_map.id
* Alpha_context.context)) :=
let '{|
Script_typed_ir.big_map.id := id;
Script_typed_ir.big_map.diff := diff;
Script_typed_ir.big_map.key_type := key_type;
Script_typed_ir.big_map.value_type := value_type
|} := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Legacy.map_to_list diff)))
(fun ctxt =>
Error_monad.op_gtgteqquestion
match id with
| Some id =>
if (|Ids|).(S.SET.mem) id ids then
Error_monad.op_gtgteqquestion (fresh ctxt)
(fun function_parameter =>
let '(ctxt, duplicate) := function_parameter in
Error_monad.__return
(ctxt, [ Alpha_context.Contract.Copy id duplicate ], duplicate))
else
Error_monad.__return (ctxt, [], id)
| None =>
Error_monad.op_gtgteqquestion (fresh ctxt)
(fun function_parameter =>
let '(ctxt, id) := function_parameter in
Error_monad.op_gtgteqquestion (unparse_ty ctxt key_type)
(fun function_parameter =>
let '(kt, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion (unparse_ty ctxt value_type)
(fun function_parameter =>
let '(kv, ctxt) := function_parameter in
Error_monad.__return
(ctxt,
[
Alpha_context.Contract.Alloc
{|
Alpha_context.Contract.big_map_diff_item.Alloc.big_map :=
id; Alpha_context.Contract.big_map_diff_item.Alloc.key_type :=
Micheline.strip_locations
kt; Alpha_context.Contract.big_map_diff_item.Alloc.value_type :=
Micheline.strip_locations
kv
|}
], id))))
end
(fun function_parameter =>
let '(ctxt, init, big_map) := function_parameter in
let pairs :=
map_fold (fun key => fun value => fun acc => cons (key, value) acc)
diff [] in
Error_monad.op_gtgteqquestion
(Error_monad.fold_left_s
(fun function_parameter =>
let '(acc, ctxt) := function_parameter in
fun function_parameter =>
let '(key, value) := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(hash_data ctxt key_type key)
(fun function_parameter =>
let '(diff_key_hash, ctxt) := function_parameter in
Error_monad.op_gtgteqquestion
(unparse_data ctxt mode key_type key)
(fun function_parameter =>
let '(key_node, ctxt) := function_parameter in
let diff_key := Micheline.strip_locations key_node
in
Error_monad.op_gtgteqquestion
match value with
| None => Error_monad.__return (None, ctxt)
| Some x =>
Error_monad.op_gtgteqquestion
(unparse_data ctxt mode value_type x)
(fun function_parameter =>
let '(node, ctxt) := function_parameter in
Error_monad.__return
((Some (Micheline.strip_locations node)),
ctxt))
end
(fun function_parameter =>
let '(diff_value, ctxt) := function_parameter
in
let diff_item :=
Alpha_context.Contract.Update
{|
Alpha_context.Contract.big_map_diff_item.Update.big_map :=
big_map; Alpha_context.Contract.big_map_diff_item.Update.diff_key :=
diff_key; Alpha_context.Contract.big_map_diff_item.Update.diff_key_hash :=
diff_key_hash; Alpha_context.Contract.big_map_diff_item.Update.diff_value :=
diff_value |} in
Error_monad.__return
((cons diff_item acc), ctxt)))))) ([], ctxt)
pairs)
(fun function_parameter =>
let '(diff, ctxt) := function_parameter in
Error_monad.__return ((Pervasives.op_at init diff), big_map, ctxt)))).
Fixpoint extract_big_map_updates {a : Set}
(ctxt : Alpha_context.context)
(fresh :
Alpha_context.context ->
Lwt.t
(Error_monad.tzresult (Alpha_context.context * Alpha_context.Big_map.id)))
(mode : unparsing_mode) (ids : (|Ids|).(S.SET.t))
(acc : list Alpha_context.Contract.big_map_diff) (ty : Script_typed_ir.ty a)
(x : a) {struct ctxt}
: Lwt.t
(Error_monad.tzresult
(Alpha_context.context * a * (|Ids|).(S.SET.t) *
list Alpha_context.Contract.big_map_diff)) :=
match (ty, x) with
| (Script_typed_ir.Big_map_t _ _ _, map) =>
Error_monad.op_gtgteqquestion (diff_of_big_map ctxt fresh mode ids map)
(fun function_parameter =>
let '(diff, id, ctxt) := function_parameter in
let Map := Script_typed_ir.big_map.diff map in
let map :=
Script_typed_ir.big_map.with_diff
(Script_typed_ir.big_map.with_id map (Some id))
(empty_map (|Map|).(Script_typed_ir.Boxed_map.key_ty)) in
Error_monad.__return
(ctxt, map, ((|Ids|).(S.SET.add) id ids), (cons diff acc)))
| (Script_typed_ir.Pair_t (tyl, _, _) (tyr, _, _) _ true, (xl, xr)) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(extract_big_map_updates ctxt fresh mode ids acc tyl xl)
(fun function_parameter =>
let '(ctxt, xl, ids, acc) := function_parameter in
Error_monad.op_gtgteqquestion
(extract_big_map_updates ctxt fresh mode ids acc tyr xr)
(fun function_parameter =>
let '(ctxt, xr, ids, acc) := function_parameter in
Error_monad.__return (ctxt, (xl, xr), ids, acc))))
| (Script_typed_ir.Union_t (ty, _) (_, _) _ true, Script_typed_ir.L x) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(extract_big_map_updates ctxt fresh mode ids acc ty x)
(fun function_parameter =>
let '(ctxt, x, ids, acc) := function_parameter in
Error_monad.__return (ctxt, (Script_typed_ir.L x), ids, acc)))
| (Script_typed_ir.Union_t (_, _) (ty, _) _ true, Script_typed_ir.R x) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(extract_big_map_updates ctxt fresh mode ids acc ty x)
(fun function_parameter =>
let '(ctxt, x, ids, acc) := function_parameter in
Error_monad.__return (ctxt, (Script_typed_ir.R x), ids, acc)))
| (Script_typed_ir.Option_t ty _ true, Some x) =>
Error_monad.op_gtgteqquestion
(Lwt.__return (Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(extract_big_map_updates ctxt fresh mode ids acc ty x)
(fun function_parameter =>
let '(ctxt, x, ids, acc) := function_parameter in
Error_monad.__return (ctxt, (Some x), ids, acc)))
| (Script_typed_ir.List_t ty _ true, l) =>
Error_monad.op_gtgteqquestion
(Error_monad.fold_left_s
(fun function_parameter =>
let '(ctxt, l, ids, acc) := function_parameter in
fun x =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(extract_big_map_updates ctxt fresh mode ids acc ty x)
(fun function_parameter =>
let '(ctxt, x, ids, acc) := function_parameter in
Error_monad.__return (ctxt, (cons x l), ids, acc))))
(ctxt, [], ids, acc) l)
(fun function_parameter =>
let '(ctxt, l, ids, acc) := function_parameter in
Error_monad.__return (ctxt, (List.rev l), ids, acc))
| (Script_typed_ir.Map_t _ ty _ true, M as m) =>
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Legacy.map_to_list m)))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(Error_monad.fold_left_s
(fun function_parameter =>
let '(ctxt, m, ids, acc) := function_parameter in
fun function_parameter =>
let '(k, x) := function_parameter in
Error_monad.op_gtgteqquestion
(Lwt.__return
(Alpha_context.Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
Error_monad.op_gtgteqquestion
(extract_big_map_updates ctxt fresh mode ids acc ty x)
(fun function_parameter =>
let '(ctxt, x, ids, acc) := function_parameter in
Error_monad.__return
(ctxt,
((|M|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.add) k
x m), ids, acc))))
(ctxt, (|M|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.empty), ids, acc)
((|M|).(Script_typed_ir.Boxed_map.OPS).(S.MAP.bindings)
(Pervasives.fst (|M|).(Script_typed_ir.Boxed_map.boxed))))
(fun function_parameter =>
let '(ctxt, m, ids, acc) := function_parameter in
let M :=
let OPS := (|M|).(Script_typed_ir.Boxed_map.OPS) in
let key := (|M|).(Script_typed_ir.Boxed_map.key) in
let value := (|M|).(Script_typed_ir.Boxed_map.value) in
let key_ty := (|M|).(Script_typed_ir.Boxed_map.key_ty) in
let boxed :=
(m, (Pervasives.snd (|M|).(Script_typed_ir.Boxed_map.boxed))) in
existT (fun _ => _) tt
{|
Script_typed_ir.Boxed_map.key_ty := key_ty;
Script_typed_ir.Boxed_map.boxed := boxed
|} in
Error_monad.__return
(ctxt,
(existT _ _
{|
Script_typed_ir.Boxed_map.key_ty :=
(|M|).(Script_typed_ir.Boxed_map.key_ty);
Script_typed_ir.Boxed_map.boxed :=
(|M|).(Script_typed_ir.Boxed_map.boxed)
|}), ids, acc)))
| (Script_typed_ir.Option_t _ _ true, None) =>
Error_monad.__return (ctxt, None, ids, acc)
| (Script_typed_ir.List_t _ _ false, v) =>
Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Map_t _ _ _ false, v) =>
Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Option_t _ _ false, None) =>
Error_monad.__return (ctxt, None, ids, acc)
| (Script_typed_ir.Pair_t _ _ _ false, v) =>
Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Union_t _ _ _ false, v) =>
Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Option_t _ _ false, v) =>
Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Chain_id_t _, v) =>
Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Set_t _ _, v) => Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Unit_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Int_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Nat_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Signature_t _, v) =>
Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.String_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Bytes_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Mutez_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Key_hash_t _, v) =>
Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Key_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Timestamp_t _, v) =>
Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Address_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Bool_t _, v) => Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Lambda_t _ _ _, v) =>
Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Contract_t _ _, v) =>
Error_monad.__return (ctxt, v, ids, acc)
| (Script_typed_ir.Operation_t _, _) =>
(* ❌ Assert instruction is not handled. *)
assert false
end.
Definition collect_big_maps {A : Set}
(ctxt : Alpha_context.context) (ty : Script_typed_ir.ty A) (x : A)
: Lwt.t (Error_monad.tzresult ((|Ids|).(S.SET.t) * Alpha_context.context)) :=
let fix collect {a : Set}
(ctxt : Alpha_context.context) (ty : Script_typed_ir.ty a) (x : a)
(acc : (|Ids|).(S.SET.t)) {struct ctxt}
: Error_monad.tzresult ((|Ids|).(S.SET.t) * Alpha_context.context) :=
match (ty, x) with
|
(Script_typed_ir.Big_map_t _ _ _, {|
Script_typed_ir.big_map.id := Some id |}) =>
Error_monad.op_gtgtquestion
(Alpha_context.Gas.consume ctxt Typecheck_costs.cycle)
(fun ctxt => Error_monad.ok (((|Ids|).(S.SET.add) id acc), ctxt))
| (Script_typed_ir.Pair_t (tyl, _, _) (tyr, _, _) _ true, (xl, xr)) =>
Error_monad.op_gtgtquestion (collect ctxt tyl xl acc)
(fun function_parameter =>
let '(acc, ctxt) := function_parameter in
collect ctxt tyr xr acc)
| (Script_typed_ir.Union_t (ty, _) (_, _) _ true, Script_typed_ir.L x) =>
collect ctxt ty x acc
| (Script_typed_ir.Union_t (_, _) (ty, _) _ true, Script_typed_ir.R x) =>
collect ctxt ty x acc
| (Script_typed_ir.Option_t ty _ true, Some x) => collect ctxt ty x acc
| (Script_typed_ir.List_t ty _ true, l) =>
List.fold_left
(fun acc =>
fun x =>
Error_monad.op_gtgtquestion acc
(fun function_parameter =>
let '(acc, ctxt) := function_parameter in
collect ctxt ty x acc)) (Error_monad.ok (acc, ctxt)) l
| (Script_typed_ir.Map_t _ ty _ true, m) =>
map_fold
(fun function_parameter =>
let '_ := function_parameter in
fun v =>
fun acc =>
Error_monad.op_gtgtquestion acc
(fun function_parameter =>
let '(acc, ctxt) := function_parameter in
collect ctxt ty v acc)) m (Error_monad.ok (acc, ctxt))
| (Script_typed_ir.List_t _ _ false, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Map_t _ _ _ false, _) => Error_monad.ok (acc, ctxt)
|
(Script_typed_ir.Big_map_t _ _ _, {| Script_typed_ir.big_map.id := None |})
=> Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Option_t _ _ true, None) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Option_t _ _ false, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Union_t _ _ _ false, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Pair_t _ _ _ false, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Chain_id_t _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Set_t _ _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Unit_t _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Int_t _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Nat_t _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Signature_t _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.String_t _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Bytes_t _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Mutez_t _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Key_hash_t _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Key_t _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Timestamp_t _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Address_t _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Bool_t _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Lambda_t _ _ _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Contract_t _ _, _) => Error_monad.ok (acc, ctxt)
| (Script_typed_ir.Operation_t _, _) =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
Lwt.__return (collect ctxt ty x no_big_map_id).
Definition extract_big_map_diff {A : Set}
(ctxt : Alpha_context.context) (mode : unparsing_mode) (temporary : bool)
(to_duplicate : (|Ids|).(S.SET.t)) (to_update : (|Ids|).(S.SET.t))
(ty : Script_typed_ir.ty A) (v : A)
: Lwt.t
(Error_monad.tzresult
(A * option (list Alpha_context.Contract.big_map_diff_item) *
Alpha_context.context)) :=
let to_duplicate := (|Ids|).(S.SET.diff) to_duplicate to_update in
let fresh :=
if temporary then
fun c => Error_monad.__return (Alpha_context.Big_map.fresh_temporary c)
else
Alpha_context.Big_map.fresh in
Error_monad.op_gtgteqquestion
(extract_big_map_updates ctxt fresh mode to_duplicate [] ty v)
(fun function_parameter =>
let '(ctxt, v, alive, diffs) := function_parameter in
let diffs :=
if temporary then
diffs
else
let dead := (|Ids|).(S.SET.diff) to_update alive in
cons
((|Ids|).(S.SET.fold)
(fun id => fun acc => cons (Alpha_context.Contract.Clear id) acc)
dead []) diffs in
match diffs with
| [] => Error_monad.__return (v, None, ctxt)
| diffs => Error_monad.__return (v, (Some (List.flatten diffs)), ctxt)
end).
Definition list_of_big_map_ids (ids : (|Ids|).(S.SET.t))
: list (|Ids|).(S.SET.elt) := (|Ids|).(S.SET.elements) ids.